perm filename UT[RUT,LSP]1 blob
sn#343776 filedate 1978-03-22 generic text, type T, neo UTF8
00010 TITLE LISP INTERPRETER 3A(1)-2
00020 SUBTTL NOTES TO SYSTEM PROGRAMMERS
00030
00040 ; COMMENTS:
00050 ;
00060 ; THERE ARE SEVERAL SETS OF COMMENTS IN THE CODE:
00070 ; THOSE IN LOWER CASE ARE ORIGINAL STANFORD COMMENTS;
00080 ; THOSE OF A SEMI-COLON FOLLOWED BY TWO $'S,
00090 ; TWO #'S, OR TWO %'S ARE UCI ADDITIONS,
00100 ; CHANGES, OR ADDITIONAL COMMENTS
00110 ; ($'S ARE USUALLY DARYLE LEWIS,
00120 ; #'S ARE GENERALLY JEFF JACOBS,
00130 ; AND %'S ARE GENERALLY BILL EARL).
00140 ;*** *** COMMENTS ARE RUTGERS MODIFICATIONS (RICK LEFAIVRE)
00150 ;[UT] [UT] COMMENTS WERE MADE AT UNIV. OF TEXAS (RICH COHEN)
00160 ; && COMMENTS WERE MADE BY RICH COHEN
00170 ;WMT WMT COMMENTS WERE MADE AT UT BY MABRY TYSON
00180
00190 ;%% VERSION DEFINITIONS:
00200
00210 LSPWHO==3 ;WMT UT
00220 LSPVER==7 ;%% MAJOR VERSION
00230 LSPMIN==3 ;%% MINOR VERSION
00240 LSPEDT==2 ;%% EDIT LEVEL
00250
00260 ; ASSEMBLY SWITCHES OF INTEREST
00270 ;
00280 ; SWITCH EXPLANATION, COMMENTS ETC.
00290 ; ------ ----------------------------------
00300 ; ALTMOD FOR ALTMODE CHARACTER. OLD WAS 175
00310 ; NOW IT'S 33 FOR 506
00320 ; QALLOW ENABLES ACCESS TO QMANGR, ONLY IF YOUR
00330 ; SYSTEM SUPPORTS QUEUE. SEVERAL SWITCHES
00340 ; ASSOCIATED WITH THE CODE
00350 ;*** OLDNIL OLD STANFORD NIL. IF OFF CAR AND CDR OF
00360 ; NIL ARE NIL A LA INTERLISP
00370 ; NONUSE OLD STANFORD VERSIONS OF MEMQ, AND ETC.
00380 ; THAT RETURNED T OR NIL.
00390 ; REALLC PROGRAM-CONTROLLED DYNAMIC REALLOCATION
00400 ; ROUTINE AND RELATED FUNCTIONS
00410 ; SYSPRG PROJECT NUMBER IF NOT ON SYS:.
00420 ; SYSPN PROGRAMMER NUMBER IF NOT ON SYS:
00430 ; SYSDEV DEVICE LOCATION OF SYSTEM.
00440 ; NOTE THAT THE ABOVE THREE ARE WHERE LISP
00450 ; EXPECTS TO FIND THE LOADER,THE
00460 ; SYMBOL TABLE AND THE NORMAL HI-SEGMENT.
00470 ; THE FUNCTION (SETSYS ...) ONLY CHANGES THE
00480 ; EXPECTED LOCATION OF THE HI-SEG
00490 ;%% SYSNAM NAME OF EXPECTED HIGH SEGMENT
00500 ;%% AND LISP LOADER AND SYMBOL TABLE
00510 ;%% INUMIN LOWEST ADDRESS AVAILABLE FOR USE AS
00520 ;%% AN INUM
00530 ;%% BCKETS NUMBER OF HASH BUCKETS
00540 ;%% SHRST LOWEST ADDRESS IN HIGH SEGMENT
00550 ;*** SPRNT SYSTEM-SUPPLIED SPRINT
00560 ;%% SYSUNV SEARCH SYSTEM UNIVERSAL LIBRARIES
00570 ;WMT RANDOM ALLOW RANDOM I/O
00580
00590 ; COMMENTS:
00600 ;WMT SFDFLG Allow SFDs
00610
00620 ; **USE FOLLOWING AT OWN RISK**
00630
00640 ; HASH NUMBER OF HASH BUCKETS WHEN STARTING
00650 ; ALVINE STANFORD EDITOR (WHO WOULD WANT IT?)
00660 ; 1 FOR ALVINE, 0 FOR NO ALVINE
00670 ; STPGAP ANOTHER STANFORD EDITOR
00680 ;*** BIGNMS BIGNUM PACKAGE (IF ON NORMAL INTEGERS ARE
00690 ;*** REDUCED FROM 36 TO 35 SIG. BITS FOR I/O)
00700
00710 PAGE
00010 SUBTTL AC DEFINITIONS AND EXTERNALS
00020
00030 ;WMT - UT'S OWN PERSONAL SET UP
00040 DEFINE SYSDEV <SIXBIT /LSP/> ;WMT- AT UT, LSP:=[5,100]
00050 DEFINE SYSNAM <SIXBIT /LSP7C1/> ;WMT- VERSION NUMBER = 7C(1)
00060 ; USING THIS TYPE NAME TO ALLOW FOR DIFFERENT VERSION OF
00070 ; LISP SIMULTANEOUSLY SO TRANSITIONS ARE SMOOTHER
00080 SHRST=600000 ;WMT- UT WANTS LOTS OF ROOM
00090 SFDFLG=0 ;WMT- UT WANTS SFDS
00100 REALLC=1 ;WMT- UT WANTS TO REALLOC
00110 RANDOM=1 ;WMT- UT WANTS RANDOM I/O
00120 ;WMT - END OF UT SET UP
00130
00140 IFNDEF SYSUNV <SYSUNV==1> ;[1]
00150
00160 IFNDEF SHRST <SHRST==400000> ;[1]
00170
00180 TWOSEG SHRST ;[1]
00190
00200 IFN SYSUNV,< ;[1]
00210 SEARCH MACTEN
00220 SEARCH UUOSYM ;[1]
00230 >
00240
00250
00260 IFNDEF OLDNIL <OLDNIL==0> ;*** NEW NIL COMPLETED 8/76
00270 IFNDEF NONUSE <NONUSE==0>
00280 IFN SHRST-400000 <QALLOW==0>
00290 IFNDEF QALLOW <QALLOW==1>
00300 IFNDEF SFDFLG <SFDFLG==1> ;WMT-1 MEANS NO SFDS
00310 IFNDEF REALLC <REALLC==0> ;%% NORMALLY OFF TO SAVE SPACE
00320 ;%% CHANGE FOR EXTENDED SYSTEM
00330 IFNDEF SPRNT <SPRNT==0> ;*** USE SPRINT IN PP PACKAGE
00340 IFNDEF PNAMES <PNAMES==1> ;*** PNAMES IN HIGH SEGMENT
00350 IFNDEF SYSPRG <SYSPRG==0 ;*** LOC. OF HIGH SEGMENT
00360 SYSPN==0>
00370 IFE SYSPRG,<IFNDEF SYSDEV,<DEFINE SYSDEV <SIXBIT /SYS/>>>
00380 IFN SYSPRG,<IFNDEF SYSDEV,<DEFINE SYSDEV <SIXBIT /DSK/>>>
00390 IFNDEF SYSNAM,<DEFINE SYSNAM <SIXBIT /ILISP/>> ;***
00400
00410 IFNDEF ALVINE <ALVINE==0> ;1 FOR ALVINE, 0 FOR NO ALVINE
00420 IFNDEF HASH <HASH==0> ;1 FOR SETTING # OF HASH BUCKETS AT SYS INIT TIME
00430 IFNDEF STPGAP <STPGAP==0> ;1 FOR STOPGAP, 0 TO DELETE IT
00440 IFNDEF BIGNMS <BIGNMS==0> ;*** 1 TO ALLOW BIGNUM MODIFICATIONS
00450 IF1,<PURGE CDR,DF>
00460 MLON
00470 IFNDEF INUMIN <INUMIN=SHRST-1> ;%% [1]
00480 INUM0=777777-<<777777-INUMIN>/2> ;%% [1]
00490 IFNDEF BCKETS <BCKETS==177>
00500 IFNDEF RANDOM <RANDOM==0> ;WMT- 1 TO ALLOW RANDOM I/O
00510
00520 PAGE
00010 ;accumulator definitions
00020 ;`sacred' means sacred to the interpreter
00030 ;`marked' means marked from by the garbage collector
00040 ;`protected' means protected during garbage collection
00050
00060 NIL=0 ;sacred, marked, protected ;atom head of NIL
00070 A=1 ;marked, protected ;results of functions and first arg of subrs
00080 B=A+1 ;marked, protected ;second arg of subrs
00090 C=B+1 ;marked, protected ;third arg of subrs
00100 AR1=4 ;marked, protected ;fourth arg of subrs
00110 AR2A=5 ;marked, protected ;fifth arg of subrs
00120 T=6 ;marked, protected ;minus number of args in LSUBR call
00130 TT=7 ;marked, protected
00140 REL=10 ;marked, protected
00150 S=11 ;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
00160 D=12
00170 R=13 ;protected
00180 P=14 ;sacred, protected ;regular push down stack pointer
00190 F=15 ;sacred ;free storage list pointer
00200 FF=16 ;sacred ;full word list pointer
00210 SP=17 ;sacred, protected ;special pushdown stack pointer
00220
00230 NACS==5 ;number of argument acs
00240
00250 X==0 ;X indicates impure (modified) code locations (*** Obsolete)
00260 TEN==↑D10
00270
00280 ;UUO definitions
00290 ;UUOs used to call functions from compiled code
00300 ;the number of arguments is given by the ac field
00310 ;the address is a pointer either to the function
00320 ;name or the code of the function
00330 OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
00340 OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
00350 OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
00360 OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
00370
00380 ;error UUOs (*** Modified for interface with smart ERRORX)
00390 OPDEF ERR1 [1B8] ;"correctable" lisp error; message can be suppressed
00400 OPDEF ERR2 [2B8] ;"serious" lisp error; no message suppression
00410 OPDEF ERR3 [3B8] ;space overflow error; no break to ERRORX
00420 OPDEF ERR4 [4B8] ;ill. mem. ref.; "serious" error with special print
00430 OPDEF STRTIP [5B8] ;print error message and continue
00440
00450 ;system UUOs
00460 OPDEF SKPINL [TTCALL 14,] ;## BETTER FOR TALK THAN SKPINC
00470 OPDEF TALK [PUSHJ P,TTYCLR+1] ;## TURN OF CONTROL O
00480
00490 ;I/O bits and constants
00500 TTYLL==105 ;teletype linelength
00510 LPTLL==160 ;line printer linelength
00520 MLIOB==203 ;max length of I/O buffer
00530 IFE RANDOM,<NIOB==2> ;no of I/O buffers per device
00540 IFN RANDOM,<NIOB==1 ;WMT
00550 BFCHRS==1200> ;WMT- # OF CHARS IN A BUFFER
00560 NIOCH==17 ;number of I/O channels
00570 FSTCH==1 ;first I/O channel
00580 TTCH==0 ;teletype I/O channel
00590 IFN SFDFLG,<SFDLEN==0> ;WMT
00600 IFE SFDFLG,<SFDLEN==5> ;WMT-DEPTH OF SFD NESTING
00610 BLKSIZE==NIOB*MLIOB+COUNT+1
00620 INB==2
00630 OUTB==1
00640 AVLB==40
00650 DIRB==4
00660
00670 ;channel data
00680 CHNAM==0 ;name of channel
00690 IFE RANDOM,<CHDEV==CHNAM+1> ;name of device
00700 IFN RANDOM,<CHBUFS==CHNAM+1 ;WMT- NUMBER OF BUFFER LOADS
00710 CHDEV==CHBUFS+1>
00720 CHFILE==CHDEV+1 ;WMT- NAME OF FILE
00730 CHEXT==CHFILE+1 ;WMT- EXTENSION
00740 CHPPN==CHEXT+1 ;ppn for input channel
00750 CHLL==CHEXT+1 ;linelength for output channel
00760 CHHP==CHLL+1 ;hposit for output channels
00770 CHOCH==CHPPN+1+SFDLEN ;oldch for input channels
00780 IFN STPGAP,<
00790 CHPAGE==CHOCH+1 ;page number for input
00800 CHLINE==CHPAGE+1 ;line number for input
00810 CHDAT==CHLINE+1 ;device data
00820 >
00830 IFE STPGAP,<
00840 CHDAT==CHOCH+1
00850 >
00860 ;WMT- CHDAT,POINTR,COUNT MUST BE CONSECUTIVE FOR I/O
00870 POINTR==CHDAT+1 ;byte pointer for device buffer
00880 COUNT==POINTR+1 ;character count for device buffer
00890
00900 ;special ASCII characters
00910 IFNDEF ALTMOD,<ALTMOD==33>
00920 SPACE==40 ;space
00930 IGCRLF==31 ;ignored cr-lf
00940 RUBOUT==177
00950 LF==12
00960 CR==15
00970 TAB==11
00980 BELL==7
00990 DBLQT==42 ;double quote "
01000
01010 ;*** ↑C INTERRUPT CHARACTERS
01020 CNTLH==10
01030 CNTLE==5
01040 CNTLB==2
01050 CNTLZ==32
01060 CNTLG==7
01070 CNTLR==22 ;CH TO RESTORE SYSTEM OBLIST 3/28/73
01080 QMARK==77
01090 CNTLF==6
01100 CNTLD==4
01110 CNTLX==30
01120
01130 ;byte pointer field definitions
01140 ACFLD==14 ;ac field
01150 XFLD==21 ;index field
01160 OPFLD==10 ;opcode field
01170 ADRFLD==43 ;adress field
01180
01190 ;external and internal symbols
01200
01210 ;EXTERNAL .JB41 ;instruction to be executed on UUO
01220 ;EXTERNAL .JBAPR ;address of APR interupt routines
01230 EXTERNAL .JBCNI ;interupt condition flags
01240 EXTERNAL .JBFF ;first location beyond program
01250 EXTERNAL .JBREL ;address of last legal instruction in core image
01260 ;EXTERNAL .JBREN ;reentry address
01270 ;EXTERNAL .JBSA ;starting address
01280 EXTERNAL .JBSYM ;address of symbol table
01290 EXTERNAL .JBTPC ;program counter at time of interupt
01300 EXTERNAL .JBUUO ;uuo is put here with effective address computed
01310 EXTERNAL .JBOPC ;$$FOR NEW REENTER FEATURES
01320 EXTERNAL .JBHRL ;HIGH SEGMENT BOUNDARY
01330 ;EXTERNAL .JBINT ;↑C INTERRUPT BLOCK ADDRESS
01340 ;EXTERNAL .JBVER ;VERSION NUMBER
01350
01360 .JB41==41 ;WMT-THESE MUST BE HERE FOR PASS 1 FOR LOC'S
01370 .JBAPR==125
01380 .JBREN=124
01390 .JBSA==120
01400 .JBINT==134
01410 .JBVER==137
01420
01430
01440 ;apr flags
01450 PDOV==200000 ;push down list overflow
01460 MPV==20000 ;memory protection violation
01470 NXM==10000 ;non-existant memory referenced
01480 APRFLG==PDOV+MPV+NXM ;any of the above
01490
01500 ;REMOTE MACRO
01510 ;WMT- MODIFIED TO PUT CODE WHERE IT CAME FROM FOR CREF
01520
01530 DEFINE REMOTE (TX)
01540 < RELOC
01550 XALL
01560 TX
01570 SALL
01580 RELOC
01590 >
01600
01610
01620 DEFINE HERE
01630 <>
01640
01650 COMMENT & WMT- HERE IS THE OLD REMOTE/HERE MACROS.
01660 DEFINE REMOTE (TX)
01670 < HERE1 <TX>>
01680
01690 DEFINE HERE1 (NEW,OLD,%G)
01700 < DEFINE %G
01710 < NEW>
01720 DEFINE REMOTE (TX)
01730 < HERE1 <TX>,<OLD
01740 %G
01750 >>>
01760 DEFINE HERE
01770 < DEFINE HERE1 (XX,YY)
01780 < YY>
01790 REMOTE>
01800 END OF OLD REMOTE/HERE MACROS &
01810 SALL
01820 PAGE
00010 SUBTTL START, EXIT, AND ↑C TRAP ROUTINES
00020
00030 ;*** This is all new as of 10/10/76 - RAL
00040
00050 ;*** Set up memory locations in Job Data Area
00060
00070 LOC .JB41
00080 JSR UUOH
00090 LOC .JBSA
00100 XWD X,START ;(MUST BE RESET SINCE CLOBBERED BY INITIAL LOAD)
00110 LOC .JBREN
00120 XWD 0,REENTR
00130 LOC .JBAPR
00140 XWD 0,APRINT ;(Reset at STRT just in case)
00150 LOC .JBINT
00160 XWD 0,CCBLK ;(Ditto)
00170 LOC .JBVER
00180 VRSN. (LSP) ;%% GENERATE VERSION ;[1]
00190
00200 RELOC 0
00210 RELOC
00220
00230
00240 REMOTE<
00250
00260 ;*** Location of sharable high segment. Changed via SETSYS.
00270 HGHDAT: SYSDEV
00280 SYSNAM
00290 0
00300 0
00310 XWD SYSPRG,SYSPN
00320 0
00330
00340 CCBLK: XWD 4,CCINT ;Interrupt Block
00350 XWD 0,2 ;Only Handles ↑C
00360 0 ;PC Goes Here
00370 X ;Other Junk Goes Here
00380
00390 CCFLAG: 0
00400 GCFLAG: 0
00410 CCONV: 0 ;WMT - FLAG TO INTERRUPT ON ↑C BEFORE MONITOR
00420 ERINT: 0
00430 FORCEC: 0 ;WMT- FLAG TO FORCE CONVERSATION AFTER REENTER
00440
00450 PAGE
00010 ;WMT - MOVED A LOT OF THIS INTO LOW SEGMENT. PROBLEMS WERE OCCURING
00020 ; ON A ↑C DURING PAGING (WHILE IN PFH). AUTOMATICALLY
00030 ; JUMPING BACK TO THE GARBAGE COLLECTOR OR CONTINUING VIA
00040 ; A ↑H MIGHT GET INTO AN INFINITE LOOP AS INTERRUPT ADDRESS
00050 ; WAS IN PFH BUT PFH GOT CALLED AGAIN (CLOBBERING IT'S
00060 ; LOCAL DATA) IN ORDER TO ACCESS THIS CODE. WHEN YOU JUMP
00070 ; BACK INTO THE MIDDLE OF PFH IT RETURNS BACK INTO THIS CODE
00080 ; SOMEWHERE CAUSING LOOPING.
00090 ; PAGE 0 IS NOT PAGED SO IT SHOULD BE OK.
00100
00110 ;*** START Entry Point
00120 START: SKIPE GCFLAG ;DID HE SOMEHOW GET OUT WHILE GCING?
00130 JRST GCING1 ;WMT- YES, TELL HIM SO
00140 SKIPE CCFLAG ;DID HE SOMEHOW GET OUT WITHOUT EXITING?
00150 JRST START3
00160 PUSH P,.JBOPC ;YES: SIMULATE A ↑C INTERRUPT
00170 POP P,CCFLAG
00180 START3: RESET
00190 HRRZ 0,.JBREL ;WMT- CHECK TO SEE IF YOU NEED TO ALLOC
00200 CAMN 0,JRELO ;WMT- COMPARE IT WITH LAST TIME
00210 JRST START1
00220 MOVEI 0,ALLOC
00230 MOVEM 0,CCFLAG ;WMT- IF DIFF, SET STARTING ADDRESS TO ALLOC
00240 START1: HRRZ 0,.JBHRL ;WMT-CHECK TO SEE IF WE HAVE HIGH SEG.
00250 JUMPN 0,START2 ;WMT- YES. JUST KEEP IT.
00260 MOVEI 0,HGHDAT
00270 GETSEG 0, ;GET SHARABLE HI-SEG
00280 HALT .
00290
00300 START2: MOVSI 17,ACCUMS ;RESTORE ACCUMS
00310 BLT 17,17
00320 SETZM CCBLK+2 ;ENABLE ↑C INTERRUPT TRAPPING
00330 JRST CCCONT ;AND EITHER CONTINUE OR ALLOC
00340
00350 ;WMT- REENTER ENTRY POINT
00360 REENTR: SETOM FORCEC ;WMT- FORCE A CONVERSATION
00370 SKIPE CCFLAG ;WMT- CHECK TO SEE IF EXITED OK
00380 JRST CCINT ;WMT- YES
00390 PUSH P,.JBOPC ;WMT- NO, SET FLAG UP RIGHT
00400 POP P,CCFLAG
00410 ;*** ↑C INTERRUPT HANDLER
00420 CCINT: SKIPE GCFLAG ;GARBAGE COLLECTING?
00430 JRST GCING ;YES: FINISH UP FIRST
00440 SKIPE CCFLAG ;ALREADY INTERRUPTED?
00450 JRST .+3 ;YES: ALREADY SAVED CONTINUE ADDR
00460 MOVE 0,CCBLK+2 ;NO
00470 MOVEM 0,CCFLAG ;SAVE CONTINUE ADDRESS
00480 SETZM CCBLK+2 ;RE-ENABLE ↑C TRAPPING
00490 ;FALLS THROUGH
00500 PAGE
00010 ;FALLS THROUGH
00020 SKIPE FORCEC ;WMT- SHOULD WE FORCE CONVERSATION
00030 JRST CCINT1-1 ;WMT- YES
00040 SKIPN CCONV ;WMT-DOES HE WANT TALK BEFORE EXIT
00050 JRST CCEXIT ;WMT- NO, GO EXIT
00060 SETZM FORCEC ;WMT- CLEAR FORCE CONVERSATION FLAG
00070 CCINT1: CLRBFI
00080 OUTSTR CCMSG
00090 INCHRW 0 ;READ THE INTERRUPT CHARACTER
00100 XCT OCR ;GIVE HIM A CR/LF
00110 CLRBFI ;WMT- IN CASE OF CRLF
00120 CCTLR: CAIN 0,CNTLR
00130 JRST CNTLRH ;WMT-MAKE SURE IT'S IN PAGE 0
00140 CCTLH: CAIN 0,CNTLH
00150 JRST CNTLHH ;WMT-MAKE SURE IT'S IN PAGE 0
00160 CCTLE: CAIN 0,CNTLE
00170 JRST [MOVE 0,STNIL
00180 MOVEI 1,NIL
00190 SETZM CCFLAG
00200 JRST ERR]
00210 CCTLB: CAIN 0,CNTLB
00220 JRST [MOVE 0,STNIL
00230 SETOM ERINT
00240 SETZM CCFLAG
00250 PUSHJ P,SPDLPT
00260 PUSHJ P,SPREDO
00270 JRST LSPRET] ;WMT- CHANGED FROM STRT
00280 CCTLD: CAIN 0,CNTLD ;*** CHANGED FROM ↑Z
00290 JRST [MOVE 0,STNIL
00300 SETZM CCFLAG
00310 JRST LSPRET] ;WMT- CHANGED FROM STRT
00320 CCTLG: CAIN 0,CNTLG
00330 JRST [MOVE 0,STNIL
00340 MOVEI 1,NIL ;WMT- MAKE SURE (ERRSET - ERRORX) CATCHES NIL
00350 SETZM CCFLAG
00360 JRST RERX]
00370 CCTLX: CAIN 0,CNTLX
00380 JRST CNTLXH ;WMT-MAKE SURE IT'S IN PAGE 0
00390 CAIN 0,CR
00400 JRST CCCONT ;*** IGNORE ↑C
00410 CAIE QMARK
00420 JRST CCINT1 ;*** TRY AGAIN
00430 OUTSTR HLPMSG
00440
00450 ; TALK ;WMT- THIS WOULD LEAVE PAGE 0
00460 JRST CCINT1
00470
00480 PAGE
00010 ; FALLS THROUGH
00020 CCEXIT: ;WMT- SAME AS ↑X
00030 CNTLXH: ;WMT - HANDLER FOR ↑X
00040 JRST DOEX2
00050 CNTLRH: HRRI 0,OBTBL(S) ;WMT- HANDLER FOR ↑R (RESTORE OBLIST)
00060 HRRM 0,VOBLIST(S)
00070 OUTSTR CNTLRM
00080 JRST CCINT1
00090 CNTLHH: SETOM ERINT ;WMT- HANDLER FOR ↑H
00100 ;*** CONTINUE AFTER ↑C
00110 CCCONT: MOVE 0,STNIL ;RESTORE 0
00120 PUSH P,CCFLAG
00130 SETZM CCFLAG
00140 POPJ P,
00150
00160 ;*** ↑C HIT WHILE GARBAGE COLLECTING
00170 GCING1: PUSH P,.JBOPC ;WMT- SAVE INTERRUPTED ADDRESS
00180 JRST .+2
00190 GCING: PUSH P,CCBLK+2 ;SAVE CONTINUE ADDRESS
00200 SETZM CCBLK+2 ;RE-ENABLE INTERRUPT
00210 PUSH P,A
00220 AOS A,CCFLAG ;INCR # OF INTERRUPTIONS THIS GC
00230 CAIL A,5 ;IF HE REALLY WANTS OUT KILL GC
00240 JRST KILLGC ;(PRIMARILY PROTECTION AGAINST GC BUGS)
00250 POP P,A ;OTHERWISE RESTORE A, PRINT MESSAGE,
00260 OUTSTR GCINGM ;WMT- MAKE SURE THIS IS IN PAGE 0
00270 POPJ P, ;AND CONTINUE WITH GC
00280 >
00290
00300 CCON: EXCH A,CCONV ;TURN ON/OFF CC FLAG
00310 POPJ P,
00320
00330 ;*** EXIT Function - This and ↑X interrupt are only legal ways to leave LISP
00340 ;*** (EXIT T) = Keep High Segment
00350 ;*** (EXIT NIL) = Remove High Segment
00360 DOEXIT: POP P,CCFLAG ;SAVE RETURN (SIMULATING ↑C)
00370 JUMPN A,DOEX2
00380 JRST DOEX1
00390 REMOTE<
00400 DOEX1: SETOM CCBLK+2 ;DISABLE ↑C TRAPPING IF NO HI-SEG AROUND
00410 MOVSI 0,1
00420 CORE 0, ;REMOVE HI-SEGMENT
00430 HALT
00440 DOEX2: MOVEI 0,ACCUMS ;SAVE ACCUMS
00450 BLT 0,ACCUMS+17
00460 EXIT 1,
00470 JRST START1 ;GO CONTINUE IF HE CONT'S
00480
00490 ACCUMS: BLOCK 20 ;ROOM FOR ACCS
00500 >
00510
00520 PAGE
00010 ;WMT - MESSAGES THAT NEED TO BE IN PAGE 0
00020
00030 REMOTE <
00040 HLPMSG: ASCIZ /
00050 CR = Continue (Ignore ↑C)
00060 ↑D = Return to Top Level
00070 ↑X = Exit to Monitor via (EXIT T)
00080 ↑H = Break Next Fn Call
00090 ↑B = Back Up and Break Last Fn Call
00100 ↑G = (ERR @ERRORX)
00110 ↑E = (ERR NIL)
00120 ↑R = Restore System OBLIST
00130 /
00140 CCMSG: ASCIZ /
00150 Interrupt (?=help): /
00160 CNTLRM: ASCIZ /OBLIST restored/
00170 GCINGM: ASCIZ /
00180 Garbage Collecting . . ./
00190 OCRM: ASCIZ /
00200 /
00210 OCR: OUTSTR OCRM
00220 >
00230 PAGE
00010 SUBTTL INITIALIZATION AND TOP LEVEL
00020
00030 STRT: RESET ;random initializations for lisp interupts
00040 MOVEI APRINT
00050 MOVEM .JBAPR
00060 MOVEI APRFLG
00070 APRENB
00080 MOVEI CCBLK ;*** SET ↑C TRAP LOC
00090 HRRM .JBINT
00100 SETZM CCBLK+2
00110 SETZM CCFLAG
00120 SETZM GCFLAG
00130 IFN ALVINE,<SETZM PSAV1>
00140 MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
00150 ;WMT- PUT LSPRET BACK IN SO THAT OPEN CHANNELS DO NOT GET
00160 ; CLOBBERED BY AN ERROR OR A ↑↑ OR A ↑
00170 LSPRET: MOVE P,C2# ;initial reg pdl ptr
00180 MOVE B,SC2
00190 PUSHJ P,UBD ;unbind specpdl
00200 SETZM BIOCHN(S) ;$$CLEAR VARS FOR BREAK PACKAGE
00210 SETZM BPMPT(S) ;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
00220 MOVEI A,INUM0
00230 MOVEM A,BINDNT(S)
00240 SETZM ERINT ;$$TURN OFF INTERRUPT FLAG
00250 SETOM ERRSW ;print error messages
00260 SETZM ERRTN# ;return to top level on errors
00270 SETOM PRVCNT# ;initialize counter for errio
00280 MOVE A,LSPRMP ;$$INITIALIZE TO TOP LEVEL PROMPT
00290 PUSHJ P,PROMPT ;$$CAN BE CHANGED BY INITPROMPT
00300 SETZM SMAC ;$$CLEAR SPLICE LIST (JUST IN CASE)
00310 IFN OLDNIL <HRROI 0,CNIL2(S)> ;INITIALIZE NIL
00320 IFE OLDNIL <SETZ 0, >
00330 MOVEM 0,STNIL# ;*** SAVE FOR RESTORATION AFTER ↑C
00340 IFE OLDNIL <MOVEI A,FAKNIL(S) ;*** GET FAKE ATOM HEADER OF NIL
00350 MOVEM A,NILHD#> ;*** AND SAVE IT FOR GC
00360
00370 IFN HASH,<
00380 SKIPE HASHFG#
00390 JRST REHASH ;rehash if necessary>
00400
00410 PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
00420 PUSHJ P,TERPRI ;*** CR BEFORE INITS CALLED
00430 SKIPN F
00440 PUSHJ P,AGC ;garbage collect only if necessary
00450 SKIPE GOBF# ;garbaged oblist flag
00460 STRTIP [SIXBIT /GARBAGED OBLIST←!/]
00470 SETZM GOBF
00480 SKIPE BPSFLG#
00490 JRST BINER2 ;binary program space exceeded by loader
00500
00510 SKIPN BSFLG# ;initial bootstrap for macros
00520 JRST BOOTS
00530 SKIPE A,INITF
00540 CALLF (A) ;evaluate initialization function
00550 PUSHJ P,TTYRET ;return all i/o to tty
00560 PUSHJ P,TERPRI
00570
00580 LISP1: MOVE S,ATMOV# ;$$MAKE SURE REL STAYS
00590 ;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
00600 SETOM TOPFLG# ;*** SET TOP-LEVEL FLAG (GETS CR BEFORE PROMPT IF TTY READ)
00610 PUSHJ P,READ ;this is the top level of lisp
00620 SETZM TOPFLG ;*** CLEAR TOP-LEVEL FLAG JUST IN CASE
00630 PUSHJ P,EVAL
00640 PUSHJ P,PRINT
00650 PUSHJ P,TERPRI
00660 JRST LISP1
00670
00680 INITFL: EXCH A,INITF1# ;## NEW INIT FILE LIST
00690 POPJ P, ;## RETURN THE OLD ONE
00700
00710 INITFN: EXCH A,INITF#
00720 POPJ P,
00730
00740 .RSET: EXCH A,RSTSW#
00750 POPJ P,
00760
00770 COMMENT %
00780 ;## OLD BOOTSTRAP CODE FOR INIT FILE, REPLACED BELOW
00790 ;BOOTSTRAPPER FOR USER'S INIT FILE
00800 BOOTS: SETOM BSFLG
00810 MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
00820 MOVEM A,BOOPT#
00830 MOVEI A,BSTYI
00840 PUSHJ P,READP1
00850 PUSHJ P,EVAL
00860 JUMPE A,BOOTOT
00870 MOVEI A,BSTYI
00880 PUSHJ P,READP1
00890 PUSH P,A
00900 MOVE A,(P)
00910 PUSHJ P,ERRSET
00920 CAIE A,$EOF$(S)
00930 JRST .-3
00940 BOOTOT: PUSHJ P,EXCISE
00950 JRST ERR
00960
00970 BSTYI: ILDB A,BOOPT
00980 POPJ P,
00990 %
01000
01010 ;## NEW IMPROVED BOOTSTRAPPER FOR USER'S INITFILE(S)
01020 ;## ALLOWS MORE THAN ONE FILE. FIRST FILE IS READ IN
01030 ;## OR IF NOT FOUND BEHAVES AS BEFORE (I.E. NO ERROR MESSAGE)
01040 ;## REMAINING FILES WILL CAUSE AN ERROR MESSAGE IF NOT FOUND.
01050 ;## THUS IF THE USER IS USING THIS TO REALLY SET UP HIS OWN
01060 ;## SYSTEM, HE WILL KNOW ABOUT A FAILURE, BUT THE FIRST
01070 ;## FILES EXISTENCE IS STILL OPTIONAL
01080
01090 BOOTS: SETOM BSFLG# ;## INDICATE BOOTSTRAP DONE
01100 SKIPN T,INITF1# ;## GET INIT FILE LIST IF IT EXISTS
01110 JRST BOOTOT ;## NOPE, EXCISE AND RETURN
01120 MOVEI A,TRUTH(S) ;## USE CHANNEL T
01130 PUSHJ P,INPUT2 ;## SET UP
01140 PUSHJ P,ININIT ;## LOOK UP
01150 JUMPN A,BOOTOK ;## IT'S THERE, GO TO IT
01160 JUMPE T,BOOTOT ;## NOT THERE AND NO OTHERS REQUESTED
01170 PUSHJ P,SETINA ;## SET UP FOR THE REST
01180 PUSHJ P,ININIT ;## LOOK UP (SECOND FILE IN LIST)
01190 JUMPE A,AIN.7 ;## NOT THERE, ERROR MESSAGE
01200 BOOTOK: MOVEI A,TRUTH(S) ;##(INC T NIL)
01210 SETZ B,
01220 PUSHJ P,INC ;## SELECT
01230 BOOTLP: PUSH P,[.+5] ;*** NEW CODE FOR NEW ERRSET
01240 JSP R,ERRST1 ;*** SET UP STACK
01250 PUSHJ P,READ
01260 PUSHJ P,EVAL
01270 JRST .-2 ;## A READ-EVAL LOOP. PROTECTED AGAINST
01280 CAIE A,$EOF$(S) ;## ALL ERRS EXCEPT $EOF$ AND ERRORX
01290 JRST BOOTLP ;## LOOP
01300 BOOTOT: PUSHJ P,EXCISE
01310 JRST STRT ;*** GO TO TOP LEVEL
01320 PAGE
00010 SUBTTL APR INTERRUPT ROUTINES
00020
00030 ;arithmetic processor interupts
00040 ;mem. protect. violation, nonex. mem. or pdl overflow
00050
00060 APRINT: MOVE R,.JBCNI ;get interupt bits
00070 TRNE R,MPV+NXM ;what kind
00080 ERR4 @.JBTPC ;an ill mem ref-will become JRST ILLMEM
00090 SKIPN GCFLAG ;*** pdl overflow - CHECK IF GCING
00100 JRST MES21 ;*** NO
00110 KILLGC: MOVE S,ATMOV ;*** JUST IN CASE
00120 STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
00130 SETZB F,GCFLAG ;*** FORCE A GC FROM TOP-LEVEL
00140 SKIPE CCFLAG
00150 JRST CCSTRT ;*** FIRST INTERRUPT IF ↑C HIT
00160 JRST STRT
00170
00180 MES21: SETZM .JBUUO
00190 SKIPL P
00200 STRTIP [SIXBIT /←REG !/]
00210 SKIPL SP
00220 STRTIP [SIXBIT /←SPEC !/]
00230 SKIPE .JBUUO
00240 SPDLOV: ERR3 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
00250 TRNE R,PDOV
00260 SKIPE .JBUUO
00270 HALT . ;lisp should not be here
00280 BINER2: SETZM BPSFLG
00290 ERR3 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
00300
00310 COMMENT %
00320 ;*** THIS CODE EVIDENTLY BELONGS TO THE "NEW" CONS ROUTINES, AND
00330 ;*** SINCE NOBODY ELSE USES IT . . .
00340 ;WMT - WARNING: THIS CODE SEEMS TO DEPEND ON END OF FREE LIST
00350 ; BEING AN ILL MEM REF. THE ADDRESS 777777 WON'T WORK IF
00360 ; THE SYSTEM IS VIRTUAL.
00370 ILLMEM: LDB R,[POINT 4,@.JBTPC,XFLD] ;get index field of bad word
00380 CAIE R,F ;does it contain f
00390 ERR3 @.JBTPC ;no! error
00400 PUSHJ P,AGC ;yes! garbage collect
00410 JRST @.JBTPC ;and continue
00420 %
00430 PAGE
00010 SUBTTL UUO HANDLER AND SUBR CALL ROUTINES
00020
00030 UUOMIN==1
00040 UUOMAX==5
00050
00060 REMOTE<
00070 UUOH: X ;jsr location
00080 JRST UUOH2>
00090 UUOH2: MOVEM T,TSV#
00100 MOVEM TT,TTSV#
00110 LDB T,[POINT 9,.JBUUO,OPFLD] ;get opcode
00120 CAIGE T,34 ;is it a function call
00130 JRST ERROR ;or a LISP error
00140 HLRE R,@.JBUUO
00150 AOJN R,UUOS ;jump if arg is not an atom
00160 PUSHJ P,CHKREC ;WMT-CHECK FOR PDL OVERFLOW
00170 LDB T,[POINT 4,.JBUUO,ACFLD]
00180 CAILE T,15
00190 MOVEI R,-15(T)
00200 HRRZ T,@.JBUUO
00210 UUOH1: HLRZ TT,(T)
00220 HRRZ T,(T)
00230 CAIN TT,SUBR(S)
00240 JRST @UUST(R)
00250 CAIN TT,FSUBR(S)
00260 JRST @UUFST(R)
00270 CAIN TT,LSUBR(S)
00280 JRST @UULT(R)
00290 CAIN TT,EXPR(S)
00300 JRST @UUET(R)
00310 CAIN TT,FEXPR(S)
00320 JRST @UUFET(R)
00330 HRRZ T,(T)
00340 JUMPN T,UUOH1
00350 PUSH P,A
00360 PUSH P,B
00370 HRRZ A,.JBUUO
00380 MOVEI B,VALUE(S)
00390 PUSHJ P,GET
00400 JUMPN A,[ HRRZ TT,(A)
00410 POP P,B
00420 POP P,A
00430 JRST UUOEX1]
00440 UUOERR: HRRZ A,.JBUUO
00450 PUSHJ P,EPRINT+2
00460 ERR2 [SIXBIT /UNDEFINED FUNCTION - UUO CALL!/] ;***
00470 SKIPA T,TT
00480 UUOSBR: HLRZ T,(T)
00490 JUMPE T,UUOERR ;*** IF FUNC PROP. IS NIL, ERROR
00500 MOVE TT,.JBUUO
00510 HRLI T,(PUSHJ P,)
00520 TLNE TT,1000 ;1000 means no push
00530 TLCA T,34600 ;<PUSHJ P,>xor<JRST>
00540 PUSH P,UUOH
00550 SOS UUOH
00560 HRRZ D,UUOH
00570 CAIG D,SHRST
00580 JRST .+3
00590 SKIPE WRTSTS
00600 JRST .+3
00610 REMOTE<
00620 UUOCL: TLNN TT,2000> ;2000 means no clobber
00630 XCT UUOCL
00640 MOVEM T,@UUOH
00650 MOVE TT,TTSV
00660 EXCH T,TSV
00670 JRST @TSV
00680
00690 UUOS: HRRZ TT,.JBUUO
00700 CAILE TT,@GCPP1
00710 CAIL TT,@GCP1
00720 JRST UUOSBR-1
00730 JRST .+2
00740 UUOEXP: HLRZ TT,(T)
00750 UUOEX1: LDB T,[POINT 5,.JBUUO,ACFLD]
00760 TRZN T,20
00770 PUSH P,UUOH
00780 PUSH P,TT
00790 JUMPE T,IAPPLY
00800 CAIN T,17
00810 MOVEI T,1
00820 MOVNS T
00830 HRLZ TT,T
00840 PUSH P,A(TT)
00850 AOBJN TT,.-1
00860 JRST IAPPLY
00870 PAGE
00010 ARGPDL: LDB T,[POINT 4,.JBUUO,ACFLD]
00020 MOVNS T
00030 HRLZ R,T
00040 ARGP1: JUMPE R,(TT)
00050 PUSH P,A(R)
00060 AOBJN R,.-1
00070 JRST (TT)
00080
00090 QTIFY: PUSHJ P,NCONS
00100 MOVEI B,CQUOTE(S)
00110 JRST XCONS
00120
00130 QTLFY: MOVEI A,0
00140 QTLFY1: JUMPE T,(TT)
00150 EXCH A,(P)
00160 PUSHJ P,QTIFY
00170 POP P,B
00180 PUSHJ P,CONS
00190 AOJA T,QTLFY1
00200
00210 PDLARG: JRST .+NACS+2(T)
00220 POP P,A+5
00230 POP P,A+4
00240 POP P,A+3
00250 POP P,A+2
00260 POP P,A+1
00270 POP P,A
00280 JRST (TT)
00290
00300 NOUUO: MOVSI B,(TLNN TT,)
00310 SKIPE A
00320 MOVSI B,(TLNA)
00330 HLLM B,UUOCL
00340 EXCH A,NOUUOF#
00350 POPJ P,
00360 PAGE
00010 ;r=0 => compiler calling a -
00020 ;r=1 => compiler calling a lsubr
00030 ;r=2 => compiler calling f type
00040
00050 UUST: UUOSBR
00060 UUOS1 ;calling l its a subr
00070 UUOS2 ;calling f
00080
00090 UUFST: UUOS9 ;calling - its a f
00100 UUOS10 ;calling l
00110 UUOSBR
00120
00130 UULT: UUOS7 ;calling - its a l
00140 UUOSBR
00150 UUOS8
00160
00170 UUET: UUOEXP
00180 UUOS5 ;calling l its an expr
00190 UUOS6 ;calling f its an expr
00200
00210 UUFET: UUOS3 ;calling - its a fexpr
00220 UUOS4 ;calling l
00230 UUOEXP
00240
00250 UUOS1: HLRZ R,(T)
00260 MOVE T,TSV
00270 JSP TT,PDLARG
00280 JRST (R)
00290
00300 UUOS3: PUSH P,(T)
00310 JSP TT,ARGPDL
00320 UUOS4A: JSP TT,QTLFY
00330 MOVEI TT,1
00340 DPB TT,[POINT 4,.JBUUO,ACFLD]
00350 UUOS6A: POP P,TT
00360 HLRZS TT
00370 JRST UUOEX1
00380
00390 UUOS4: PUSH P,(T)
00400 MOVE T,TSV
00410 JRST UUOS4A
00420 PAGE
00010 UUOS5: HLRZ R,(T)
00020 MOVE T,TSV
00030 JSP TT,PDLARG
00040 MOVNS T
00050 DPB T,[POINT 4,.JBUUO,ACFLD]
00060 MOVE TT,R
00070 JRST UUOEX1
00080
00090 UUOS6: PUSH P,(T)
00100 PUSH P,UUOH
00110 PUSH P,.JBUUO
00120 JSP TT,ILIST
00130 JSP TT,PDLARG
00140 POP P,.JBUUO
00150 POP P,UUOH
00160 JRST UUOS6A
00170 UUOS8: SKIPA TT,CILIST
00180 UUOS7: MOVEI TT,ARGPDL
00190 HRRM TT,UUOS7A
00200 MOVE TT,.JBUUO
00210 TLNN TT,1000
00220 PUSH P,UUOH
00230 HLRZ TT,(T)
00240 JRST @UUOS7A ;OR ILIST
00250 REMOTE<
00260 UUOS7A: ARGPDL>
00270
00280 UUOS9: PUSH P,T
00290 JSP TT,ARGPDL
00300 UUS10A: JSP TT,QTLFY
00310 MOVSI T,2000
00320 IORM T,.JBUUO
00330 POP P,T
00340 JRST UUOSBR
00350
00360 UUOS10: PUSH P,T
00370 MOVE T,TSV
00380 JRST UUS10A
00390
00400 PAGE
00010 SUBTTL ERROR HANDLER AND BACKTRACE
00020 ;subroutine to print sixbit error message
00030 ERRSUB: MOVSI A,(POINT 6,0)
00040 HRR A,.JBUUO
00050 MOVEM A,ERRPTR#
00060 ERRORB: ILDB A,ERRPTR
00070 CAIN A,01 ;conversion from sixbit
00080 POPJ P,
00090 CAIN A,77
00100 JRST [ PUSHJ P,TERPRI
00110 JRST ERRORB]
00120 ADDI A,40
00130 PUSHJ P,TYO
00140 JRST ERRORB
00150
00160 ;subroutine to return output to previously selected device
00170 OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
00180 SOSL PRVCNT ;when prvcnt goes negative, then reselect
00190 POPJ P,
00200 PUSH P,PRVSEL# ;previously selected output
00210 POP P,TYOD
00220 POPJ P,
00230
00240 ;subroutine to force error messages out on tty
00250 ERRIO: TALK ;*** UNDO ↑O (MOVED FROM BELOW)
00260 MOVE B,ERRSW
00270 CAIE B,INUM0 ;inum0 specifies to print message on selected device
00280 AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
00290 POPJ P,
00300 MOVE B,[JRST TTYO]
00310 EXCH B,TYOD
00320 MOVEM B,PRVSEL
00330 POPJ P,
00340
00350 ;ERRTN: 0 ;0 => top level *
00360 ;- => pdl to reset to - stored by errorset
00370 ;+ => string tyo pout rtn flag
00380 REMOTE<
00390 ERRSW: -1> ;0 means no prnt on error
00400 PAGE
00010 ;subroutine to search oblist for closest function to address in r
00020 ERSUB3:
00030 MOVEI A,QST(S)
00040 IFN OLDNIL< HRROI NIL,CNIL2(S)>
00050 IFE OLDNIL< SETZ NIL, >
00060
00070 HRLZ B,INT1
00080 MOVNS B
00090 SETZB AR2A,GOBF
00100 PUSH P,.JBAPR
00110 MOVEI C,[ SETOM GOBF
00120 JRST ERRO2G]
00130 HRRM C,.JBAPR
00140 HRRZ C,VOBLIST(S) ;## GET CURRENT OBLIST
00150 HRRM C,RHX5
00160 HRRM C,RHX2 ;## AND UPDATE LOCATIONS WHICH REF OBLIST
00170 HLRZ C,@RHX5
00180 ERRO2B: JUMPE C,[ AOBJN B,.-1
00190 POP P,.JBAPR ;oblist done, restore
00200 JRST PRINC] ;print closest match
00210 HLRZ TT,(C)
00220 ERRO2C: HRRZ TT,(TT)
00230 JUMPE TT,ERRO2G
00240 HLRZ AR1,(TT)
00250 CAIN AR1,LSUBR(S)
00260 JRST ERRO2H
00270 CAIE AR1,SUBR(S)
00280 CAIN AR1,FSUBR(S)
00290 JRST ERRO2H
00300 HRRZ TT,(TT)
00310 JRST ERRO2C
00320
00330 ERRO2H: HRRZ TT,(TT)
00340 HLRZ TT,(TT)
00350 CAMLE TT,AR2A ;le to prefer car to quote
00360 CAMLE TT,R
00370 JRST ERRO2G
00380 MOVE AR2A,TT
00390 HLRZ A,(C)
00400 ERRO2G: HRRZ C,(C)
00410 JRST ERRO2B
00420 PAGE
00010 ;dispatcher for error message uuos
00020 ERROR: MOVEI A,APRFLG
00030 APRENB A, ;enable interupts
00040 SETOM ERRTYP# ;*** SET FLAG FOR "SERIOUS" ERROR
00050 LDB A,[POINT 9,.JBUUO,OPFLD] ;get opcode
00060 CAIL A,UUOMIN ;what
00070 CAILE A,UUOMAX ;is it?
00080 JRST ILLUUO ;an illegal opcode
00090 JRST @ERRTAB-UUOMIN(A) ;or LISP error
00100 ERRTAB: ERROR1 ;1 ;"correctable" LISP error
00110 ERROR2 ;2 ;"serious" LISP error
00120 ERROR3 ;3 ;space overflow error
00130 ERROR4 ;4 ;ill. mem. ref.
00140 STRTYP ;5 ;print error message and continue
00150
00160 ERROR3: MOVE P,ERRTN ;IF IN ERRSET, RESTORE P TO THAT LEVEL
00170 SKIPN P
00180 MOVE P,C2 ;else to top level
00190 SETOM UUO2# ;$$ AND DON'T ENTER ERRORX
00200 ERROR2: SKIPN ERRSW
00210 JRST ERREND
00220 JRST ERRPRI ;*** "SERIOUS" ERRORS ALWAYS PRINT MESSAGE BEFORE BREAKING
00230
00240 ERROR1: SKIPN ERRSW
00250 JRST ERREND ;dont print message, call (err nil)
00260 SETZM ERRTYP ;*** CHANGE FLAG TO "CORRECTABLE" ERROR
00270 MOVE A,RSTSW ;*** CHECK *RSET FLAG TO CHECK FOR PRINT
00280 CAIN A,ERRORX(S) ;*** @ERRORX = NO
00290 JRST ERREND
00300 ERRPRI: PUSHJ P,ERRIO ;print message on tty
00310 PUSHJ P,TERPRI
00320 PUSHJ P,ERRSUB ;print the message
00330 JRST ERRBK ;go the backtrace
00340
00350 STRTYP: PUSHJ P,ERRIO
00360 PUSHJ P,ERRSUB ;print message and continue
00370 PUSHJ P,OUTRET
00380 JRST @UUOH
00390
00400 ;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
00410 .ERROR: SETOM ERRTYP ;*** SET FLAG FOR "SERIOUS" ERROR
00420 JUMPE A,ERREND
00430 SKIPN ERRSW
00440 JRST ERREND
00450 PUSHJ P,ERRIO
00460 PUSHJ P,TERPRI
00470 PUSHJ P,PRINC
00480 JRST ERREND
00490 PAGE
00010 ERROR4: HRRZ A,.JBUUO
00020 MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
00030 JRST ERSUB2
00040
00050 ILLUUO: HRRZ A,UUOH
00060 MOVEI B,[SIXBIT / ILL UUO FROM !/]
00070
00080 ERSUB2: SKIPN ERRSW
00090 JRST ERREND ;dont print message
00100 PUSH P,A
00110 PUSH P,B
00120 PUSHJ P,ERRIO
00130 PUSHJ P,TERPRI
00140 PUSHJ P,PRINL2 ;print number
00150 POP P,A
00160 STRTIP (A) ;print message
00170 POP P,R
00180 PUSHJ P,ERSUB3 ;print nearest oblist match
00190 ERRBK:
00200 IFN ALVINE,<
00210 SKIPE BACTRF
00220 PUSHJ P,BKTRC ;print backtrace
00230 >
00240 PUSHJ P,OUTRET ;return to previous device
00250
00260 ERREND: SETZ A, ;## %CLRBFI USED TO BE HERE(FOR ERR NIL)
00270 SKIPN UUO2 ;$$NO ERRORX IF OVERFLOW ERROR
00280 JRST .+3
00290 SETZM UUO2 ;$$RESET TO ZERO
00300 JRST RERX ;$$BOUNCE BACK TO ERRORX
00310 SKIPE RSTSW ;$$NEW *RSET FEATURE
00320 SKIPN ERRSW ;***CHECK ERRSET FLAG
00330 JRST ERR ;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
00340 PUSHJ P,%CLRBFI ;## CLEAR TTY BUFFER. ELIMINATE FLUSHING
00350 SKIPE A,ERRTYP ;*** GET ERROR TYPE FLAG
00360 MOVEI A,TRUTH(S) ;*** NZ = SERIOUS, Z = CORRECTABLE
00370 PUSHJ P,NCONS ;*** SET TO PASS FLAG TO ERRORX
00380 MOVEI B,ERRORX(S) ;$$SET TO CALL ERROR HANDLER
00390 PUSHJ P,XCONS ;$$CREATE FORM (ERRORX flag)
00400 JRST EVAL ;$$AND EVALUATE IT
00410 PAGE
00010 ERR: SETZM INHERR ;CLEAR RERX FLAG JUST IN CASE
00020 CAIN A,ERRORX(S) ;$$BOUNCE TO ERRORX IF A=ERRORX
00030 JRST RERX
00040 ERR2: SKIPN ERRTN
00050 JRST LSPRET ;not in an errset, or bad error -- go to top level
00060 ;WMT- CHANGED FROM STRT
00070 MOVE P,ERRTN
00080 ERR1: POP P,B
00090 PUSHJ P,UBD ;unbind to previous errset
00100 POP P,ERRSW
00110 POP P,ERRTN
00120 SKIPN INHERR#
00130 JRST ERRP4 ;and proceed
00140
00150 RERX: SETZM INHERR ;$$ POP TO A BREAK ERRSET
00160 MOVE B,ERRSW
00170 CAIE B,ERRORX(S)
00180 SETOM INHERR
00190 JRST ERR2
00200
00210 ERRSET: MOVE B,A ;*** New ERRSET with entry points for
00220 HRRZ A,(B) ;*** in-line compiled ERRSET code
00230 CAIN A,0
00240 SKIPA A,[1] ;*** (USE T (1) FOR ERR FLAG IF MISSING)
00250 HLRZ A,(A)
00260 JSP R,ERRST1
00270 HLRZ A,(B) ;*** GET EXPRESSION AND EVALUATE IT
00280 PUSHJ P,EVAL
00290 JRST ERRST2 ;*** NO ERROR, SO GO UNDO STACK
00300
00310 ERRST1: PUSH P,PA3 ;*** SET UP STACK FOR ERROR TRAP
00320 PUSH P,PA4 ;*** (CALLED FROM COMPILED CODE)
00330 PUSH P,ERRTN ;*** NOTE THAT THE COMPILER HAS FAITH IN THE
00340 PUSH P,ERRSW ;*** FACT THAT 5 ITEMS ARE PUSHED - DON'T
00350 PUSH P,SP ;*** DISAPPOINT HIM
00360 MOVEM P,ERRTN
00370 MOVEM A,ERRSW
00380 JRST (R)
00390
00400 ERRST2: PUSHJ P,NCONS ;*** COME HERE FOR NON-ERROR RETURN
00410 ;*** (CALLED FROM COMPILED CODE)
00420 SETZM INHERR ;CLEAR RERX FLAG
00430 JRST ERR1
00440
00450 SYSCLR: SETZM BSFLG ;FUNCTION TO MAKE SYSTEM LOOK NEW
00460 SETZM CONSVA ;## RESET CONS COUNT
00470 SETZM GCTIM ;## RESET GC TIME
00480 JRST EXCISE ;## EXCISE
00490 PAGE
00010 ;error messages
00020
00030
00040
00050
00060 RMERR: MOVE A,T ;$$ BAD READ MACRO, GET THE NAME
00070 PUSHJ P,EPRINT+2 ;$$
00080 ERR2 [SIXBIT /UNDEFINED READ MACRO!/]
00090
00100 BNDERR: PUSHJ P,EPRINT+2 ;$$ATTEMPT TO REBIND NIL OR T (*** OR ILLEGAL VAR)
00110 ERR2 [SIXBIT /CAN'T BE USED AS VARIABLE!/]
00120
00130 RPAERR: PUSHJ P,EPRINT+2 ;$$PRINT OUT OFFENDING ITEM
00140 ERR2 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
00150
00160 RPDERR: PUSHJ P,EPRINT+2 ;$$
00170 ERR2 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
00180
00190 DOTERR: SETZM OLDCH
00200 ERR2 [ SIXBIT /DOT CONTEXT ERROR!/]
00210 UNDFUN: HLRZ A,(AR1)
00220 PUSHJ P,EPRINT
00230 ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
00240 UNBVAR: PUSHJ P,EPRINT
00250 ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
00260 NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
00270 NOPNAM: ERR2 [SIXBIT /NO PRINT NAME - INTERN!/]
00280 NOLIST: ERR2 [SIXBIT /NO LIST - MAKNAM!/]
00290 TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
00300 TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
00310 UNDTAC: HRRZ A,(C)
00320 UNDTAG: PUSHJ P,EPRINT
00330 ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
00340 SETERR: PUSHJ P,EPRINT+2 ;$$BAD SET OR SETQ
00350 ERR2 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
00360 EG1: PUSHJ P,EPRINT
00370 ;???? WMT - SHOULD THIS BE ERR2?
00380 ERR1 [SIXBIT /UNDEFINED PROG TAG - GO!/]
00390 EG2: PUSHJ P,EPRINT+2
00400 ERR2 [SIXBIT /GO WITH NO PROG!/]
00410 EG3: ERR2 [SIXBIT /RETURN WITH NO PROG!/]
00420 ARRERR: ERR2 [SIXBIT /ARRAY SUBSCRIPT OUT OF BOUNDS!/] ;***
00430 PAGE
00010 IFN ALVINE,<
00020
00030 ;backtrace subroutine
00040 BKTRC: MOVEI D,-1(P)
00050 MOVN A,BACTRF
00060 ADDI A,INUM0
00070 JUMPL A,[ ADD A,P ;backtrace specific number
00080 JRST .+3]
00090 SKIPN A,ERRTN ;backtrace to previous errset
00100 MOVE A,C2 ;or top level
00110 HRRZM A,BAKLEV#
00120 STRTIP [SIXBIT /←BACKTRACE←!/]
00130 BKTR2: CAMG D,BAKLEV
00140 JRST FALSE ;done
00150 HRRZ A,(D) ;get pdl element
00160 CAIGE A,FS(S)
00170 JUMPN A,.+2 ;this is (hopefully) a true program address
00180 SOJA D,BKTR2 ;not a program address, continue
00190 CAIN A,ILIST3
00200 JRST BKTR1A ;argument evaluation
00210 BKTR1B: CAIN A,CPOPJ
00220 JRST [ HLRZ A,(D) ;calling a function
00230 PUSHJ P,PRINC
00240 XCT "-",CTY
00250 STRTIP [SIXBIT /ENTER !/]
00260 SOJA D,BKTR2]
00270 HLRZ B,-1(A)
00280 CAILE B,(JCALLF 17,@(17))
00290 CAIN B,(PUSHJ P,) ;tests for various types of calls
00300 CAIGE B,(FCALL)
00310 SOJA D,BKTR2 ;not a proper function call
00320 PUSH P,-1(A) ;save object of function call
00330 MOVEI R,-1(A) ;location of function call
00340 PUSHJ P,ERSUB3 ;print closest oblist match
00350 MOVEI A,"-"
00360 PUSHJ P,TYO
00370 POP P,R
00380 TLNE R,17
00390 HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
00400 HRRZS R
00410 HLRO B,(R)
00420 AOSN B
00430 JRST [ HRRZ A,R ;was calling an atomic function
00440 PUSHJ P,PRINC ;print its name
00450 JRST .+2]
00460 PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
00470 MOVEI A," "
00480 PUSHJ P,TYO
00490 BKTR1: SOJA D,BKTR2 ;continue
00500
00510 BKTR1A: HRRZ B,-1(D)
00520 CAIE B,EXP2
00530 CAIN B,ESB1
00540 JRST .+2
00550 JRST BKTR1B ;hum, not really evaluating arguments
00560 HLRE B,-1(D)
00570 ADD B,D
00580 HLRZ A,-3(B)
00590 JUMPE A,BKTR1
00600 PUSHJ P,PRINC
00610 XCT "-",CTY
00620 STRTIP [SIXBIT /EVALARGS !/]
00630 JRST BKTR1
00640 ;*** TURNED OFF UNLESS ALVINING
00650 BAKGAG: EXCH A,BACTRF#
00660 POPJ P,
00670 >
00680 PAGE
00010 SUBTTL TYI AND TYO
00020 ;input
00030 ITYI: PUSHJ P,TYI ;## RETURN ASCII VALUE OF INPUT CH
00040 FIXI: ADDI A,INUM0
00050 POPJ P,
00060
00070 TYI: MOVEI AR1,1 ;## TO TEST FOR LINED TYPESEQUENCE #, ETC
00080 PUSHJ P,TYIA
00090 JUMPE A,.-1
00100 CAME A,IGSTRT ;start of comment or ignored cr-lf
00110 POPJ P,
00120 PUSHJ P,COMMENT
00130 JRST TYI+1
00140
00150 TYIA: SKIPE A,OLDCH ;## IF CH IN OLDCH
00160 JRST TYI1 ;## TAKE CARE OF IT
00170 TYID: XCT TYI2 ;## INPUT A CHARACTER
00180 REMOTE<
00190 TYI2: JRST TTYI> ;sosg x for other device input
00200 ;other device input
00210 JRST TYI2X
00220 TYI3B: ILDB A,@TYI3# ;pointer
00230 XCT TYI3A ;## SEE IF LINED TYPE WORD
00240 REMOTE<
00250 TYI3A: TDNN AR1,@X> ;pointer
00260 JRST CHKLC ;## NO, OK
00270
00280 IFN STPGAP,<
00290 MOVE A,@TYI3A
00300 CAMN A,[<ASCII / />+1] ;page mark for stopgap
00310 AOSA PGNUM ;increment page number
00320 MOVEM A,LINUM
00330 >
00340 MOVNI A,5
00350 ADDM A,@TYI2 ;adjust character count for line number
00360 AOS @TYI3 ;increment byte pointer over line number and tab
00370 JRST TYID
00380
00390 REMOTE<
00400 TYI2X: INPUT X,
00410 TYI2Y: STATZ X,740000
00420 ERR2 AIN.8 ;input error
00430 IFN RANDOM,<
00440 TYI2W: AOS X> ;WMT- INCREMENT BUFFER COUNT
00450 TYI2Z: STATO X,20000
00460 JRST TYI3B ;continue with file
00470 TYIEOF: JRST TYI2Q ;END OF FILE
00480 >
00490 TYI2Q: SKIPN INREAD# ;WMT-WARN IF UNEXPEXTED EOF
00500 JRST TYI2Q1
00510 MOVE A,INCH ;WMT- GET PATH OF INPUT CHANNEL
00520 PUSHJ P,CHNPT1 ;WMT- GO GET IT
00530 PUSHJ P,EPRNT1 ;WMT- PRINT IT OUT.
00540 STRTIP [SIXBIT /WARNING-EOF HIT DURING A READ←!/]
00550 SETZM INREAD ;WMT-CLEAR IT
00560 TYI2Q1: PUSH P,T
00570 PUSH P,C
00580 PUSH P,R
00590 PUSH P,AR1
00600 MOVE A,INCH
00610 HRRZ C,CHTAB(A) ;get location of data for this channel
00620 HLRZ T,CHTAB(A) ;inlst -- remaining files to input
00630 JUMPE T,TYI2E ;none left -- stop
00640 PUSHJ P,SETIN ;start next input
00650 PUSHJ P,ININIT ;## INIT THE FILE
00660 JUMPE A,AIN.7 ;## CAN'T FIND FILE, ERROR
00670 POP P,AR1
00680 POP P,R
00690 POP P,C
00700 POP P,T
00710 JRST TYI
00720
00730 TYI2E: PUSHJ P,INCNT ;(inc nil t)
00740 ;*** TALK Removed to allow output from several files to be suppressed with one ↑O
00750 MOVEI A,$EOF$(S) ;we are done
00760 JRST ERR
00770
00780 IFN STPGAP,<
00790 PGLINE: MOVE C,[POINT 7,LINUM]
00800 PUSHJ P,NUM10 ;convert ascii line number to a integer
00810 ADDI A,INUM0
00820 MOVE B,PGNUM
00830 ADDI B,INUM0+1
00840 JRST XCONS>
00850
00860 REMOTE<
00870 OLDCH: 0
00880 IFN STPGAP,<
00890 PGNUM: 0
00900 LINUM: 0
00910 0>> ;zero to terminate num10
00920
00930 ;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
00940 ; IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
00950 ; - TAKES NO ARGUMENTS
00960 ECHO: SETO A,
00970 GETLCH A ;GET STATUS BITS
00980 TLC A,4 ;COMPLEMENT THE ECHO BIT
00990 SETLCH A ;RESTORE THE BITS
01000 TLNE A,4 ;TEST TO GET FINAL VALUE
01010 JRST FALSE
01020 JRST TRUE
01030
01040 ;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
01050 ; - 0 ARGS AND RETURNS NIL
01060 %CLRBFI:CLRBFI ;CLEAR BUFFER
01070 SETZM SMAC ;CLEAR SPLICE LIST
01080 SETZM OLDCH ;CLEAR LAST CHAR.
01090 JRST FALSE
01100 PAGE
00010 ;teletype input
00020
00030 TTYI: SKIPE DDTIFG ;## DDT MODE?
00040 JRST TTYID
00050 move a,linl ; reset chrct on a read [ut]
00060 movem a,chct ; (this has caused problems in the past)
00070 SKPINC ;*** this gets rid of redundant prompts
00080 JRST DOPROM ;*** when line is almost full
00090 TTYINC: INCHWL A ;***
00100
00110 TTYXIT: CAMN A,ERRCHR ;## BELL, NEED NOT BE ↑G
00120 JRST TTYERC
00130 SKIPN PSAV ;*** CHECK FOR SPECIAL CNTRL CHARS ONLY IN READ
00140 JRST CHKLC ;WMT-CHECK FOR LC INPUT
00150 CAMN A,RERCHR
00160 JRST DORUB ;*** RESTART READ
00170 CAME A,EDCHR
00180 JRST CHKLC ;WMT-CHECK FOR LC INPUT
00190 SETOM EDFLAG# ;*** SET FLAG FOR EDIT
00200 JRST TTYI ;*** AND IGNORE CHAR
00210
00220 DOPROM: SKIPE TLKFLG# ;*** DO WE NEED A TALK (FIRST PROMPT)
00230 TALK
00240 SETZM TLKFLG ;*** NO TALK ON SUBSEQUENT PROMPTS
00250 SKIPE TOPFLG ;*** DO WE NEED A TERPRI (TOP-LEVEL READ)
00260 PUSHJ P,TERPRI
00270 SETZM TOPFLG ;*** ONLY ONCE PER TOP-LEVEL READ
00280 ASKINP: MOVE A,PROMX ;&& ISSUE PROMPT TO USER
00290 CAIGE A,INUMIN ;&& SKIP IF INUM
00300 JRST ASKIN1 ;&& ELSE ITS AN ATOM
00310 MOVEI A,-INUM0(A) ;&& CONVERT FROM INUM0
00320 OUTCHR A ;&& ISSUE PROMPT CHAR
00330 JRST TTYINC
00340 ASKIN1: PUSH P,C ;&& MUST PRESERVE REG. C
00350 SETCM C,(A) ;&& CHECK ATOM HEADER
00360 TLNE C,777777 ;&& (CAR OF AN ATOM)
00370 JRST [POP P,C ;&& --NOT AN ATOM
00380 ERR1 [SIXBIT /PROMPT NO LONGER AN ATOM!/]]
00390 MOVEI B,PNAME(S)
00400 PUSHJ P,GET ;&& GET ATOM'S PNAME
00410 PUSH P,C+1 ;&& SAVE REG. TO RESTORE LATER
00420 SETZ C+1, ;&& ASSURE NULL CHAR FOR OUTSTR
00430 ASKIN2: HLRZ B,(A) ;&& B := CAR A
00440 MOVE C,(B) ;&& GET A FULL WORD OF PRINT NAME
00450 OUTSTR C ;&& TYPE IT
00460 HRR A,(A) ;&& A := CDR A
00470 TRNE A,777777 ;&& IS A = NIL ?
00480 JRST ASKIN2 ;&& NO...MORE PROMPT TO TYPE
00490 POP P,C+1 ;&& MUST RESTORE REGISTERS
00500 POP P,C ;&& LIKEWISE
00510 JRST TTYINC ;WMT- GO READ CHAR
00520
00530 CHKLC: CAIL A,"a" ;WMT-CHECK FOR LOWER CASE
00540 CAILE A,"z" ;WMT-LOOK FOR LOWER CASE
00550 POPJ P, ;WMT-WAS NOT LOWER CASE
00560 SKIPE %TTYUC(S) ;WMT-DO NOTHING IF NIL
00570 SUBI A,"a"-"A" ;WMT-MAKE IT UPPER CASE
00580 POPJ P, ;WMT-ALL DONE
00590
00600 TTYERC:
00610 IFN ALVINE,<
00620 SKIPE PSAV1# ;bell from alvine?
00630 JRST [ MOVE P,PSAV1 ;yes, return to alvine
00640 JRST @ED1];$$DOUBLY IMPROVED MAGIC>
00650 MOVEI A,NIL ;$$ RETURN NIL AS THE VALUE
00660 JRST RERX ;$$ RETURN TO AN ERRORX ERRSET
00670
00680 TTYID: INCHRW A ;single character input ddt submode style
00690 CAIE A,RUBOUT
00700 JRST TTYXIT
00710 OUTCHR ["\"] ;echo backslash
00720 DORUB: SKIPE PSAV
00730 JRST RDRUB ;rubout in read resets to top level of read
00740 POPJ P,
00750
00760 ERRCH: MOVEI A,-INUM0(A) ;## CHANGE BELL CHARACTER
00770 EXCH A,ERRCHR ;## RETURN OLD CHARACTER
00780 JRST FIX1A ;## CONVERT IT
00790
00800 EDITCH: MOVEI A,-INUM0(A) ;*** CHANGE EDIT CHARACTER
00810 EXCH A,EDCHR
00820 JRST FIX1A
00830
00840 RERDCH: MOVEI A,-INUM0(A) ;*** CHANGE REREAD CHARACTER
00850 EXCH A,RERCHR
00860 JRST FIX1A
00870
00880 REMOTE <
00890 ERRCHR: BELL
00900 EDCHR: CNTLF
00910 RERCHR: CNTLZ
00920 PROMCH: "*"
00930 PROMX: "*"+INUM0
00940 LSPRMP: "*"+INUM0>
00950
00960 PROMPT: SKIPN A ;&& SKIP IF NON-NIL
00970 JRST PROMP1 ;&& RETURN CURRENT PROMPT
00980 PUSH P,A ;&& SAVE ARG
00990 CAIGE A,INUMIN ;&& TEST WHETHER INUM OR ATOM
01000 PUSHJ P,ATOM ;&& (SUBR ATOM BASHES REG. A)
01010 SKIPN A ;&& SKIP IF ONE OR THE OTHER
01020 JRST [POP P,A
01030 PUSHJ P,EPRINT
01040 ERR1 [SIXBIT /NEW PROMPT NOT ATOMIC!/]]
01050 POP P,A ;&& GET BACK ARG IF ATOM BASHED IT
01060 EXCH A,PROMX ;&& SAVE NEW PROMPT
01070 POPJ P, ;&& AND RETURN OLD ONE
01080 PROMP1: MOVE A,PROMX ;&& JUST RETURN CURRENT PROMPT
01090 POPJ P,
01100
01110
01120 INTPRP: SKIPN A
01130 SKIPA A,LSPRMP
01140 EXCH A,LSPRMP ;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
01150 POPJ P, ;$$
01160
01170 READP: SKPINC ;$$ T IFF A CHARACTER HAS BEEN TYPED
01180 JRST FALSE ;$$ (DOES NOT CHECK OLDCH)
01190 JRST TRUE
01200
01210 UNTYI: MOVEI B,-INUM0(A) ;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
01220 MOVEM B,OLDCH
01230 POPJ P, ;$$ RETURN ARG AS VALUE
01240
01250 DDTIN: EXCH A,DDTIFG#
01260 POPJ P,
01270 PAGE
00010 ;output
00020 ITYO: SUBI A,INUM0
00030 PUSHJ P,TYO
00040 JRST FIXI
00050
00060 TYO: CAIG A,CR
00070 JRST TYO3
00080 SOSGE CHCT
00090 JRST TYO1
00100 JRST TYOD
00110 REMOTE<
00120 TYOD: JRST TTYO+X ;sosg x for other device
00130 ;other device output
00140 JRST TYO2V
00150 TYO5: IDPB A,X
00160 POPJ P,
00170
00180 TYO2V:
00190 IFN RANDOM,<
00200 TYO2W: AOS X> ;WMT- INCREMENT BUFFER COUNT
00210 TYO2X: OUT X,
00220 JRST TYO5
00230 ERR2 [SIXBIT /OUTPUT ERROR!/]
00240 >
00250
00260 TYO1: PUSH P,A ;linelength exceeded
00270 MOVEI A,IGCRLF ;inored cr-lf
00280 PUSHJ P,TYOD
00290 PUSHJ P,TERPRI ;force out a cr-lf, with special mark
00300 POP P,A
00310 SOSA CHCT
00320 TYO4: POP P,B
00330 JRST TYOD
00340
00350 TYO3: CAIGE A,TAB
00360 JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
00370 PUSH P,B
00380 MOVE B,LINL
00390 CAIN A,TAB
00400 JRST [ SUB B,CHCT
00410 IORI B,7 ;simulate tab effect on chct
00420 SUB B,LINL
00430 SETCAM B,CHCT
00440 JRST TYO4]
00450 CAIN A,CR
00460 MOVEM B,CHCT ;reset chct after a cr
00470 JRST TYO4
00480
00490 LINELENGTH:
00500 JUMPE A,LINEL1
00510 SUBI A,INUM0
00520 HRRM A,LINL
00530 HRRM A,CHCT
00540 LINEL1: HRRZ A,LINL
00550 JRST FIXI
00560
00570 CHRCT: MOVE A,CHCT
00580 comment &
00590
00600 This new code doesn't seem to work. Don't know yet whether
00610 it's bad code, or a TRMOP. bug.
00620
00630 HRRZ B,TYOD ;WMT- UPDATE WHERE YOU ARE IF TTY:
00640 CAIE B,TTYO ; ARE WE LOOKING AT TTY:?
00650 JRST FIXI ; NO
00660 SETO C, ; GET THIS JOB NUMBER
00670 TRMNO. C, ; AND NOW THE TERMINAL #
00680 JRST FIXI ; HUH? OH, WELL..
00690 MOVE D,[XWD 2,B] ; ARGUMENTS
00700 MOVEI B,1011 ; READ THE CARRIAGE POSITION
00710 TRMOP. D,
00720 JRST FIXI
00730 MOVE A,LINL ; LINELENGTH
00740 SUB A,D ;- CURRENT POSITION
00750 MOVEM A,CHCT ;= CHARACTERS LEFT
00760 &
00770 JRST FIXI
00780
00790 REMOTE<
00800 LINL: TTYLL
00810 CHCT: TTYLL>
00820 PAGE
00010 ;teletype output
00020 TTYO: OUTCHR A ;output single character in a
00030 POPJ P,
00040
00050 TTYRET: PUSHJ P,OUTCNT
00060 JRST INCNT
00070
00080 ;*** NEW ROUTINE TO TURN OFF CNTRL-O - ELIMINATES PROBLEM WHEREBY ↑O
00090 ;*** WAS STRUCK AFTER ERROR MESSAGE, ETC., WAS ALREADY PRINTED
00100 ;*** (I.E., WHILE LAST BUFFER WAS BEING DUMPED) SO TALK COULDN'T UNDO IT.
00110 ;*** WE NOW WAIT FOR ALL OUTPUT TO BE FLUSHED BEFORE TURNING OFF ↑O
00120 TTYCLR: SETZ A, ;USER ENTRY POINT (RETURNS NIL)
00130 PUSH P,A ;SYSTEM ENTRY POINT (SAVES A)
00140 SKIPA A,PJOBNO ;WMT- AVOID DOING THE UUO REPEATEDLY
00150 PJOB A, ;GET JOB #
00160 MOVEM A,PJOBNO ;WMT- SAVE JOB NUMBER
00170 TRMNO. A, ;GET UDX FOR CONTROLLING TERMINAL
00180 JRST TTYCL2 ;ERROR - FORGET IT
00190 MOVEM A,TRMTAB+1 ;STICK UDX INTO TRMTAB
00200 TTYCL1: MOVE A,[XWD 2,TRMTAB]
00210 TRMOP. A, ;CHECK IF OUTPUT BUFFER EMPTIED
00220 JRST TTYCL2 ;YES - CAN NOW TURN OFF ↑O
00230 MOVEI A,144 ;NO - WAIT 100 MSEC. MAIN EFFECT IS TO GIVE
00240 HIBER A, ;UP CONTROL OF MACHINE WHILE BUFFER IS FLUSHED
00250 JRST TTYCL2 ;ERROR - FORGET IT
00260 JRST TTYCL1 ;CHECK IT AGAIN
00270 TTYCL2: SKPINL ;THIS CLEARS ↑O BIT
00280 JFCL
00290 JRST POPAJ
00300 REMOTE<
00310 PJOBNO: 0 ;WMT- HIS JOB NUMBER
00320 TRMTAB: 2 ;(.TOSOP)
00330 200000+X> ;(UDX)
00340
00350 REMOTE<
00360 TTOCH: 0
00370 IFN STPGAP,<
00380 0 ;tty page number always zero
00390 0 ;tty line number -- always zero
00400 >
00410 TTOLL: TTYLL
00420 TTOHP: TTYLL>
00430 PAGE
00010 SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL
00020 ;convert ascii to sixbit for device initialization routines
00030 SIXMAK: SETZM SIXMK2#
00040 MOVE AR1,[POINT 6,SIXMK2]
00050 HRROI R,SIXMK1
00060 PUSHJ P,PRINTA ;use print to unpack ascii characters
00070 MOVE A,SIXMK2
00080 POPJ P,
00090
00100 SIXMK1: ADDI A,40
00110 TLNN AR1,770000
00120 POPJ P, ;last character position -- ignore remaining chars
00130 CAIN A,"."+40
00140 MOVEI A,0 ;ignore dots at end of numbers for decimal base
00150 CAIN A,":"+40
00160 HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
00170 IDPB A,AR1
00180 POPJ P,
00190
00200 ;subroutine to process next item in file name list
00210 INXTIO: JUMPE T,NXTIO
00220 HRRZ T,(T)
00230 NXTIO: HLRZ A,(T)
00240 PUSHJ P,ATOM
00250 JUMPE A,CPOPJ ;non-atomic
00260 HLRZ A,(T)
00270 JRST SIXMAK ;make sixbit if atomic
00280
00290 ;right normalize sixbit
00300 LSH A,-6
00310 SIXRT: TRNN A,77
00320 JRST .-2
00330 POPJ P,
00340 PAGE
00010 ;## SUBROUTINE TO TEST FOR A DEVICE OR QUEUE. USED BY I/O ROUTINES
00020 ;## AND THE QUEUE ROUTINES. LEAVES A=0 IF NOT AN ATOM AND B=0
00030 ;## DEVICE OR QUEUE.
00040
00050 DEVCHK: PUSHJ P,NXTIO ;## MAKE SIXBIT IF AN ATOM
00060 LDB B,[POINT 6,A,35];## GET LAST CHAR
00070 CAIN B,':' ;## DEVICE?
00080 TRZA A,77 ;## YES, CLEAR CHAR BUT LEAVE B INTACT
00090 SETZ B, ;## NO, CLEAR B
00100 POPJ P, ;## DONE, IF A=0 OR B=0, NOT A DEVICE
00110
00120 ;## SUBROUTINE TO PARSE THE I/O SPECIFICATION. DEFAULT IS DSK IF
00130 ;## NO DEVICE SPECIFIED.
00140 IOSUB: MOVEM T,DEVDAT# ;## SAVE ARG FOR ERRORS
00150 SKIPE DEV ;## DEVICE ALREADY SPECIFIED?
00160 JRST IOSUB1 ;## YES, FORGET DEFAULT
00170 SETZM PPN ;## CLEAR PPN
00180 IFE SFDFLG,< SETZM PPN+1> ;WMT-CLEAR A SFD LOCATION
00190 MOVSI A,'DSK' ;## STORE DSK AS DEFAULT
00200 MOVEM A,DEV
00210 IOSUB1: PUSHJ P,DEVCHK ;## SEE IF DEVICE SPECIFIED
00220 JUMPE A,IOPPN ;## NON-ATOMIC ARG, MUST BE PPN OR (FILE.EXT)
00230 JUMPE B,IOFIL2 ;## NOT A DEVICE, MUST BE FILE NAME
00240 SETZM PPN
00250 IFE SFDFLG,< SETZM PPN+1> ;WMT-CLEAR A SFD LOCATION
00260 MOVEM A,DEV
00270 IODEV3: PUSHJ P,INXTIO
00280 IOPPN: JUMPN A,IOFIL2 ;not ppn or (fil.ext)
00290 PUSHJ P,PPNEXT
00300 JUMPN A,IOEXT ;(fil.ext)
00310 HLRZ A,(T)
00320 PUSHJ P,CNVPPN ;## CONVERT PPN
00330 IFN SFDFLG,< MOVEM A,PPN> ;WMT-SAVE PPN
00340 JRST IODEV3 ;%% DON'T ZAP DEVICE NAME FOR PPN
00350
00360 COMMENT & WMT-NO PATH HERE
00370 IOFIL: JUMPN A,IOFIL2 ;was it an atom
00380 JUMPE T,CPOPJ ;no, was it nil (end)
00390 PUSHJ P,PPNEXT
00400 JUMPE A,CPOPJ ;see a ppn, no file named
00410 END OF NO PATH COMMENT &
00420 IOEXT: HLRZ A,(T) ;(file.ext)
00430 HRRZ A,(A) ;get cdr == extension
00440 PUSHJ P,SIXMAK
00450 HLLM A,EXT
00460 HLRZ A,(T)
00470 HLRZ A,(A) ;get car = file name
00480 PUSHJ P,SIXMAK
00490 FIL: PUSH P,A
00500 PUSHJ P,INXTIO
00510 JRST POPAJ
00520
00530 IOFIL2: CAIN B,":"-40
00540 POPJ P, ;saw a :,not file name
00550 SETZM EXT ;file name -- clear extension
00560 JRST FIL
00570
00580 PPNEXT: JUMPE T,CPOPJ ;end of file name list
00590 HLRZ A,(T)
00600 HRRZ A,(A) ;cdar
00610 JRST ATOM ;ppn iff (not(atom(cdar l)))
00620
00630 CHNSUB: MOVE T,A
00640 HLRZ A,(T)
00650 PUSHJ P,ATOM
00660 JUMPE A,TRUE ;non-atomic head of list -- no channel named
00670 HLRZ A,(T)
00680 PUSHJ P,SIXMAK
00690 ANDI A,77
00700 CAIN A,":"-40
00710 JRST TRUE ;device name, assume channel name t
00720 HLRZ A,(T) ;channel name -- return it
00730 HRRZ T,(T)
00740 POPJ P,
00750 ;## LEFT HALF OF A CHANNEL TABLE ENTRY IS THE REMAINING
00760 ;## FILE LIST. RH POINTS TO EXTENDED HEADER.
00770
00780 REMOTE<
00790 CHTAB=.-FSTCH
00800 BLOCK NIOCH>
00810
00820 PAGE
00010 ;search for channel name in chtab
00020 TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
00030 MOVE C,CHTAB(A)
00040 CAME B,CHNAM(C)
00050 AOBJN A,.-2
00060 CAMN B,CHNAM(C)
00070 POPJ P, ;found it!!!
00080 JRST FALSE ;lost
00090
00100 ;search for channel name in chtab, and if not there find a free channel, and
00110 ;if no free channel, allocate a new buffer and channel
00120 TABSRC: MOVE B,A
00130 PUSHJ P,TABSR1
00140 JUMPN A,DEVCLR ;found the channel
00150 PUSH P,B
00160 MOVE B,0
00170 PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
00180 JUMPE A,[ERR2 [SIXBIT $NO I/O CHANNELS LEFT !$]]
00190 POP P,B
00200 JUMPN C,DEVCLR ;found free channel which had buffer space previously
00210 PUSH P,A ;must allocate new buffer
00220 MOVEI A,BLKSIZ
00230 SETZ D, ;SPECIAL RELOCATION - SEE LOAD
00240 PUSHJ P,MORCOR ;expand core for buffer if necessary
00250 MOVE C,A
00260 POP P,A
00270 HRRM C,CHTAB(A)
00280 DEVCLR: HRRZ C,CHTAB(A)
00290 MOVEM B,CHNAM(C) ;[UT] (LH)=INPUT/OUTPUT BIT,(RH)=PTR TO CHNL NAME
00300 HRRZM A,CHANNEL#
00310 POPJ P,
00320
00330 ;subroutine to reset all i/o channels -- used by excise and realloc
00340 IOBRST: HRRZ A,.JBREL
00350 HRLM A,.JBSA
00360 MOVEM A,CORUSE#
00370 HRRZ B,.JBSYM ;WMT
00380 CAIG B,SHRST ;WMT- MAKE SURE IT ISN'T IN HIGH SEG
00390 MOVEM A,.JBSYM
00400 SETZM CHTAB+FSTCH
00410 MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
00420 BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
00430 JRST (R)
00440 PAGE
00010 INPUT1: PUSHJ P,CHNSUB ;determine channel name
00020 MOVEI AR1,(A) ;## SAVE CH NAME
00030 EXCH AR1,(P) ;## EXHANGE WITH RETURN ADDR
00040 PUSH P,AR1 ;## AND STUFF THE RETURN ADDR. IN
00050 INPUT2: PUSHJ P,TABSRC ;## GET PHYSICAL CHANNEL NUMBER
00060 MOVEM A,CHANNEL ;## SAVE IT
00070 SETZM DEV ;## CLEAR DEV SO THAT WE CAN
00080 ;## DEFAULT IF APPROPRIATE
00090 JRST SETIN1 ;## SET UP FOR INITIALIZTION
00100
00110 INPUT: PUSHJ P,INPUT1
00120 PUSHJ P,ININIT
00130 INFAIL: JUMPE A,AIN.7 ;## CAN'T FIND FILE
00140 JRST POPAJ
00150
00160 COMMENT & WMT- NO PATH HERE
00170 BINPUT: PUSHJ P,INPUT1 ;## IMAGE BINARY INPUT
00180 PUSHJ P,BNINIT
00190 JRST INFAIL
00200 END OF NO PATH COMMENT &
00210
00220 ISFILE: JUMPE A,.+5 ;## ROUTINE TO TELL USER IF A FILE EXISTS
00230 PUSH P,A ;## SAVE A IF NON-NIL
00240 MOVEI A,(B) ;## GET THE FILE NAME
00250 PUSHJ P,NCONS ;## (FILNAM)
00260 POP P,B ;## GET THE DEVICE BACK
00270 PUSHJ P,XCONS ;## (DEV FILNAM) OR (FILNAM) WHEN HERE
00280 PUSH P,A ;## SAVE IT FOR RETURN
00290 PUSHJ P,RENSUB ;## SEE IF IT'S THERE
00300 PUSH P,A ;## SAVE THE ANSWER
00310 PUSHJ P,RENCLR ;## CLEAR THE CHANNEL
00320 POP P,A ;## ANSWER IN A
00330 JUMPN A,POPAJ ;## IF NON-NIL, THEN IT'S THERE
00340 JRST POPBJ ;## POP ANSWER OFF AND RETURN NIL
00350
00360 RENSUB: MOVEM A,DEVDAT ;## SAVE IT FOR ERROR MSGS
00370 PUSHJ P,GENSYM ;## DON'T CLOBBER CURRENT CHANNELS
00380 MOVE T,DEVDAT ;## GET IT BACK
00390 PUSHJ P,INPUT2 ;## SET UP AND OPEN
00400 JRST ININIT ;## AND INIT
00410
00420 RENAME: PUSHJ P,RENSUB ;## RENAME SETUP
00430 JUMPE A,RENCLR ;## NIL IF CAN'T FIND FILE
00440 IFE SFDFLG,< ;WMT- GET OLD FILES PATH SO YOU CAN RENAME PROPERLY
00450 MOVE A,CHANNEL ;WMT- CHANNEL NUMBER
00460 HRRZM A,SFDBLK ;WMT- THIS ARG TO PATH WILL GET CHANNEL'S PATH
00470 MOVE A,[XWD SFDLEN+4,SFDBLK]
00480 PATH. A, ;WMT- GO DO IT
00490 JRST RENCLR ;WMT- FAILED???
00500 MOVE A,CHANNEL ;WMT- PUT PATH INTO CHANNEL PATH
00510 HRRZ C,CHTAB(A)
00520 MOVE A,[XWD PPN,CHPPN] ;WMT- SET UP BLT TO MOVE IT
00530 ADDI A,(C) ;WMT- INDEX
00540 BLT A,CHPPN+SFDLEN(C) ;WMT- TRANSFER PATH
00550 >
00560 PUSHJ P,SETINA ;## PROCESS THE NEW NAME
00570 XCT RNAME ;## EXECUTE
00580 JRST RENCLR ;## RETURN NIL IF FAILURE
00590 PUSHJ P,RENCLR ;## CLEAR CHANNEL
00600 JRST TRUE ;## AND RETURN T IF GOOD
00610
00620 REMOTE <
00630 RNAME: RENAME X,LOOKIN ;## RENAME FILE
00640 >
00650 DELERR: PUSHJ P,AIOP
00660 PUSHJ P,RENCLR ;## KILL THE CHANNEL
00670 ERR2 [SIXBIT /CAN'T DELETE FILE !/]
00680
00690 DELETE: PUSHJ P,RENSUB ;## FIRST SETUP(ALLOWS DEFAULT TO DSK:)
00700 JRST .+2 ;## ALREADY INIT'ED
00710 DELET1: PUSHJ P,ININIT ;## INIT AND LOOKUP
00720 JUMPE A,DELET2 ;## IF FILE NOT THERE IGNORE
00730 SETZM LOOKIN ;## BLAST FILE NAME
00740 SETZM EXT ;## AND EXTENSION
00750 XCT RNAME ;## AND RENAME OUT OF EXISTENCE
00760 JRST DELERR ;## RENAME FAILURE
00770 DELET2: JUMPE T,RENCLR ;## DONE
00780 MOVEM T,DEVDAT ;## SAVE REST OF LIST FOR MSGS.
00790 PUSHJ P,SETINA ;## PROCESS NEXT FILE
00800 JRST DELET1 ;## AND DO IT AGAIN
00810
00820 RENCLR: PUSH P,CHANNEL ;## CLEAR CHANNEL
00830 SETO B, ;## FAKE (INC RENCHANNEL T)
00840 PUSHJ P,IOSEL ;## RELEASE THE CHANNEL
00850 JRST POPAJ ;## RETURN NIL (IOSEL CHANGED THINGS)
00860
00870
00880 ;## TO LOOK UP A UFD FOR DIRECTORY FNS. SUBR
00890
00900 UFDINP: PUSH P,A
00910 MOVEI T,(B)
00920 PUSHJ P,TABSRC
00930 MOVEM A,CHANNEL ;## HAVE A CHANNEL
00940 MOVE A,[XWD 'DSK','UFD']
00950 HRLZM A,EXT
00960 HLLZM A,DEV
00970 IFN SFDFLG,<
00980 SETZ B,
00990 AOBJP B,.+1 ;## UFD'S SHOULD BE ON [1,1]
01000 MOVEM B,PPN>
01010 SKIPN A,T
01020 IFN SFDFLG,< PUSHJ P,MYPPN> ;## IF B=NIL, DEFAULT TO USER'S PPN
01030 IFE SFDFLG,<PUSHJ P,PATH> ;WMT-IF B=NIL, DEFAULT TO USER'S PATH
01040 MOVEM A,DEVDAT
01050 PUSHJ P,CNVPPN ;## CONVERT PPN
01060 SETZ T, ;## ZAP T (NO MORE FILES)
01070 IFE SFDFLG,<
01080 JUMPE C,NOSFD ;WMT-IF NO SFD'S
01090 MOVEI B,'SFD' ;WMT-ELSE EXT IS .SFD
01100 HRLZM B,EXT
01110 SETZ A, ;WMT-LAST SFD SHOULD BE 0
01120 EXCH A,PPN(C) ;WMT-A IS FILE(SFD) NAME
01130 JRST FDLU
01140 NOSFD: MOVE A,[XWD 1,1] ;WMT-UFD'S ON 1,1
01150 EXCH A,PPN
01160 FDLU:>
01170 PUSHJ P,SETIN2 ;## SETUP
01180 PUSHJ P,BNINIT ;## INIT AS BINARY
01190 JUMPE A,ERR ;## ERR NIL IF NOT THERE
01200 PUSHJ P,ININBF ;## SET UP BUFFERS
01210 JRST POPAJ ;## RETURN CHANNEL
01220 MYPPN: GETPPN A, ;## GET PPN
01230 CAI ;## WIERD SKIP RETURN ON THIS UUO
01240 HLRZ C,A ;## ASSUME PPN'S ARE INUMS
01250 HRRZI A,INUM0(A) ;## CONVERT
01260 PUSHJ P,NCONS
01270 HRRZI B,INUM0(C)
01280 JRST XCONS ;## (PROJ PRGRM)
01290
01300 CNVPPN: MOVS A,(A) ;## ASSUME PPNS INUMS
01310 HRRI A,-INUM0(A) ;## LH=CDR, RH=CAR
01320 IFN SFDFLG,<
01330 MOVSS A ;## SWAP HALVES
01340 HLR A,(A) ;## RH=CADR NOW
01350 HRRI A,-INUM0(A)
01360 POPJ P,>
01370
01380 IFE SFDFLG,<
01390 HRLZM A,PPN ;WMT-SAVE PROJ# IN PPN
01400 MOVSS A ;WMT-SWAP HALVES AGAIN
01410 MOVS A,(A) ;WMT-AND AGAIN (CDR)
01420 HRRI A,-INUM0(A) ;WMT-PROG#
01430 HRRM A,PPN ;WMT-SAVE PROG# IN PPN
01440 HLRZS A ;WMT-A IS NOW CDDR
01450 MOVNI C,SFDLEN ;WMT-COUNT OF SFDS
01460 PUSH P,A ;WMT-RESERVE SOME ROOM
01470 NXTSFD: JUMPE A,ENDSFD ;WMT-DONE WITH SFDS
01480 MOVS A,(A) ;WMT-GET CDR,,CAR
01490 HLRZM A,(P) ;WMT-SAVE CDR
01500 HRLM C,(P) ;WMT- AND INDEX
01510 MOVEI A,(A) ;WMT-ONLY WANT CAR
01520 PUSHJ P,SIXMAK ;WMT-MAKE IT SIXBIT
01530 HLRE C,(P) ;WMT- RETRIEVE INDEX
01540 MOVEM A,PPN+1+SFDLEN(C);WMT-SAVE THIS SFD
01550 HRRZ A,(P) ;WMT-RESTORE A
01560 AOJL C,NXTSFD ;WMT-INCREMENT AND GO GET MORE
01570 ENDSFD: SETZM PPN+1+SFDLEN(C) ;WMT-GUARANTEE A 0 SFD
01580 ADDI C,SFDLEN ;WMT-SFD COUNT
01590 MOVEI B,SFDBLK
01600 MOVEM B,LPPN ;WMT-MAKE SURE IT POINTS TO PATH BLOCK
01610 JRST POPBJ> ;WMT-RETURN NIL,CLEAR STACK
01620
01630 ;WMT-SOME STUFF FOR PATHS
01640 IFE SFDFLG,<
01650 PATH: ;FSUBR- RETURN PRESENT PATH IF ARG=NIL
01660 ; ELSE IF ONE ARG THEN RETURN PATH OF THAT CHANNEL
01670 ; ELSE SET PATH TO ARG
01680 ; RETURNS PRESENT PATH UNLESS YOU COULDN'T SET PATH IN WHICH
01690 ; CASE IT RETURNS NIL
01700 JUMPE A,GETPTH
01710 HRRZ B,(A) ;WMT-CHECK FOR ONE ARG
01720 JUMPE B,CHNPTH ;WMT- ONE ARG, PRESUME A CHANNEL
01730 PUSH P,A ;WMT-SAVE ARG
01740 PUSHJ P,CNVPPN ;WMT-FILL LOOK UP BLOCK IN
01750 HRRZI A,-2 ;WMT-0,,-2 SETS PATH
01760 PUSHJ P,PATH1 ;WMT-GO DO IT
01770 JUMPE A,POPBJ ;WMT-IF NIL, THEN IGNORE POP AND RETURN
01780 JRST POPAJ ;WMT-ELSE RETURN ARGUMENT
01790
01800 PATH1: SETZM SFDBLK+1 ;WMT-USE ALREADY EXISTING SCAN SWITCH
01810 PATH2: MOVEM A,SFDBLK ;WMT-LOAD PATH ARGUMENT
01820 MOVE B,[XWD SFDLEN+4,SFDBLK] ;WMT-AC FOR PATH
01830 PATH. B, ;WMT-GO DO IT
01840 JRST FALSE ;WMT-PATH UUO FAILED, RETURN NIL
01850 JRST TRUE ;WMT-ALL IS COOL
01860
01870 GETPTH: HRRZI A,-1 ;WMT-0,,-1 GETS THE PATH
01880 PUSHJ P,PATH1 ;WMT-GO GET PATH
01890 JUMPE A,CPOPJ ;WMT-HUH?
01900 ; THIS RETURNS A PATH THAT IS IN PPN.... AS (PROJ# PROG# SFD1 ...)
01910 GTPTH3: PUSH P,[NIL] ;WMT-END OF VALUE LIST
01920 MOVEI B,SFDLEN ;WMT-COME FROM BOTTOM UP
01930 GTPTH2: MOVE A,PPN(B) ;WMT-GET SFD
01940 JUMPE A,GTPTH1 ;WMT-A 0 SFD
01950 PUSH P,B ;WMT-SAVE INCREMENT
01960 PUSHJ P,SIXATM ;WMT-MAKE AN ATOM
01970 POP P,B ;WMT-RETRIEVE INDEX
01980 EXCH B,(P) ;WMT-GET VALUE LIST, SAVE INDEX
01990 PUSHJ P,CONS ;WMT-CONS ON NEW ONE
02000 EXCH A,(P) ;WMT-SAVE VALUE, GET INDEX
02010 SKIPA B,A ;WMT-MOVE INDEX TO B AND SKIP
02020 GTPTH1: SETZM (P) ;WMT-MAKE SURE VALUE LIST IS NIL IF NO SFD
02030 SOJG B,GTPTH2 ;WMT-ARE WE DONE?
02040 HRRZ A,PPN ;WMT-YES, NOW WORK ON PROG. NUM
02050 MOVEI A,INUM0(A) ;WMT-MAKE INTO AN INUM
02060 POP P,B ;WMT-GET SFD LIST
02070 PUSHJ P,CONS ;WMT-CONS ON PROG NUM
02080 MOVE B,A
02090 HLRZ A,PPN ;WMT-NOW GET PROJ NUM
02100 MOVEI A,INUM0(A) ;WMT-MAKE INUM
02110 JRST CONS ;WMT-CONS IT ON AND RETURN
02120
02130 ; RETURNS (DEV: (PATH) (FILE.EXT)(FILE2.EXT)...)
02140 ; FOR CHANNEL IT IS CALLED WITH
02150 ; FOR TTY IT RETURNS (TTY:)
02160
02170 CHNPTH: HLRZ B,(A) ;WMT- GET ARG
02180 JUMPE B,PTHTTY ;WMT-CHECK FOR TTY: CASE
02190 PUSHJ P,TABSR1 ;WMT- GET PHYSICAL CHANNEL #
02200 JUMPN A,CHNPT1 ;WMT- FOUND IT AS INPUT
02210 TLO B,400000 ;WMT- LOOK FOR IT AS OUTPUT
02220 PUSHJ P,TABSR1
02230 JUMPE A,CPOPJ ;WMT- ERROR. RETURN NIL
02240 CHNPT1: HRRZM A,SFDBLK ;WMT- ARGUMENT FOR PATH.
02250 HRRZ C,CHTAB(A) ;WMT- POINTER TO DATA
02260 PUSH P,C ;WMT- SAVE IT
02270 DMOVE A,CHFILE(C) ;WMT- NAME OF FILE
02280 PUSH P,B ;WMT- (SAVE EXTENSION)
02290 PUSHJ P,SIXATM ;WMT- MAKE AN ATOM
02300 EXCH A,(P) ;WMT- AND SAVE
02310 ;WMT- AND GET EXTENSION
02320 JUMPE A,.+5 ;WMT- CHECK IF NONE
02330 PUSHJ P,SIXATM ;WMT- MAKE ATOM
02340 MOVE B,(P) ;WMT- GET FILE
02350 PUSHJ P,XCONS ;WMT- MAKE (FILE . EXT)
02360 MOVEM A,(P) ;WMT- SAVE IT
02370
02380 MOVE A,[XWD SFDLEN+4,SFDBLK] ;WMT- ARG FOR PATH.
02390 PATH. A, ;WMT- GO GET CHANNEL PATH
02400 ERR2 [SIXBIT /CAN'T GET PATH !/]
02410 PUSHJ P,GTPTH3 ;WMT- MAKE INTO PATH EXPRESSION
02420 EXCH A,(P) ;WMT- SAVE IT
02430 PUSHJ P,NCONS ;WMT- MAKE ((FILE . EXT))
02440 POP P,B ;WMT- GET PATH AGAIN
02450 PUSHJ P,XCONS ;WMT- MAKE ((PATH) (FILE.EXT))
02460 EXCH A,(P) ;WMT- SAVE AND GET CHANNEL DATA
02470 MOVE A,CHDEV(A) ;WMT- GET DEVICE
02480 PUSHJ P,SIXCAT ;WMT- MAKE ATOM
02490 POP P,B ;WMT- GET REST
02500 JRST CONS ;WMT- RETURN (DEV (PATH)(FILE.EXT))
02510 PTHTTY: MOVSI A,'TTY' ;WMT- NIL CHANNEL NAME = TTY
02520 PUSHJ P,SIXCAT ;WMT- GET NAME
02530 JRST NCONS ;WMT- MAKE LIST
00010 SCAN: ; TURNS OFF SCAN SWITCH IF ARG IS NIL, ELSE TURNS IT ON
00020 ; RETURNS NIL OR NON-NIL ACCORDING TO WHAT IT WAS BEFORE
00030 PUSH P,A ;WMT-SAVE ARG
00040 HRRZI A,-1 ;WMT-WANT DEFAULT PATH
00050 PUSHJ P,PATH1
00060 MOVEI A,2 ;WMT-BIT 34 INDICATES /SCAN
00070 TDZN A,SFDBLK+1 ;WMT-IF SCAN IS ON, SETS A TO NIL AND SKIPS
00080 MOVEI A,TRUTH(S) ;WMT-HERE T IS NO SCAN, NIL IS SCAN
00090 CAMN A,(P) ;WMT-SEE IF SAME AS ASKED FOR
00100 JRST STSCAN ;WMT-SAME, THUS MUST SET AS PER REQUEST
00110 SKIPE (P) ;WMT-NOPE, BUT MAYBE NON-NIL VERSUS T
00120 JUMPN A,STSCAN ;WMT-NEITHER NIL, MUST SET SCAN
00130 JRST POPAJ ;WMT-WANTED WHAT IT WAS ALREADY,GIVE BAK ARG
00140 STSCAN: MOVEI A,3 ;WMT-SET SCAN SWITCHES
00150 ANDCMM A,SFDBLK+1 ;WMT-FLIP BITS 34,35, ZERO 0-33
00160 HRRZI A,-2 ;WMT-0,,-2 SETS PATH (AND SCAN)
00170 PUSHJ P,PATH2 ;WMT-GO SET IT
00180 POP P,A ;WMT-RETURN NOT ARGUMENT
00190 JRST NOT>
00010 SETINA: MOVE A,CHANNEL ;## FOR ROUTINES THAT PROCESS MORE
00020 HRRZ C,CHTAB(A) ;## AND KEEP THE CHANNEL IN CHANNEL
00030
00040 SETIN: MOVEM A,CHANNEL
00050 MOVE A,CHDEV(C)
00060 MOVEM A,DEV
00070 IFN SFDFLG,<
00080 MOVE A,CHPPN(C)
00090 MOVEM A,PPN>
00100 IFE SFDFLG,<
00110 MOVE A,[XWD PPN,CHPPN] ;WMT-SET CHANNEL PATH
00120 ADDI A,(C) ;WMT-INDEX
00130 MOVSS A ;WMT-PUT IN RIGHT ORDER
00140 BLT A,PPN+SFDLEN ;WMT-TRANSFER PATH
00150 MOVEI A,SFDBLK ;WMT-RESET LPPN
00160 MOVEM A,LPPN
00170 SETZM SFDBLK+1> ;WMT-USE DEFAULT SCAN
00180 SETIN1: PUSHJ P,IOSUB ;get device and file name
00190 SETIN2: MOVEM A,LOOKIN ;file name
00200 MOVE A,DEV
00210 MOVEM A,BDEV ;## ALLOW IMAGE BINARY MODE
00220 DEVCHR A,
00230 TLNN A,INB
00240 JRST AIN.2 ;not input device
00250 TLNN A,AVLB
00260 JRST AIN.4 ;not available
00270 MOVE A,CHANNEL
00280 DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
00290 DPB A,[POINT 4,BNINIT,ACFLD] ;## FOR IMAGE BINARY
00300 DPB A,[POINT 4,RNAME,ACFLD] ;## FOR RENAME
00310 DPB A,[POINT 4,INLOOK,ACFLD]
00320 DPB A,[POINT 4,ININBF,ACFLD]
00330 HLLZS EXT ;%% CLEAR RIGHT HALF
00340 SETZM LOOKIN+2 ;%% CLEAR THIRD WORD
00350 HRRZ B,CHTAB(A)
00360 HRLM T,CHTAB(A) ;save remaining file name list
00370 MOVE A,DEV ;WMT-SAVE CHANNEL DEVICE
00380 MOVEM A,CHDEV(B)
00390 MOVE A,LOOKIN ;WMT- FILE NAME
00400 MOVEM A,CHFILE(B) ;WMT- SAVE IT
00410 MOVE A,EXT ;WMT- EXTENSION
00420 MOVEM A,CHEXT(B) ;WMT- SAVE IT
00430 IFN SFDFLG,<
00440 MOVE A,PPN ;WMT-SAVE CHANNEL PPN
00450 MOVEM A,CHPPN(B)>
00460 IFE SFDFLG,<
00470 MOVE A,[XWD PPN,CHPPN] ;WMT-SAVE CHANNEL PATH
00480 ADDI A,(B) ;WMT-INDEX
00490 BLT A,CHPPN+SFDLEN(B)> ;WMT-SAVE WHOLE PATH
00500 IFN RANDOM,< SETZM CHBUFS(B)> ;WMT- ZERO BUFFER COUNT
00510 MOVEI A,CHDAT(B)
00520 MOVEM A,DEV1 ;pointer to bufdat
00530 MOVEM A,BDEV1 ;## IMAGE BINARY MODE
00540 POPJ P, ;## SET UP FOR INITIALIZTION
00550 REMOTE<
00560
00570 BNINIT: INIT X,13 ;## INIT DEVICE IN IMAGE BINARY
00580 BDEV: X
00590 BDEV1: X
00600 JRST AIN.7 ;## CAN'T INIT
00610 JRST INITOK
00620 ININIT: INIT X,
00630 DEV: X
00640 DEV1: X
00650 JRST AIN.7 ;cant init
00660 INITOK:
00670 ; PUSH B,DEV ;WMT-ALREADY DID THIS (SET CHDEV)
00680 ; PUSH B,PPN ;WMT-ALREADY DID THIS (SET CHPPN)
00690 ;WMT- A TEMPORARY PATCH UNTIL MONITOR GETS FIXED
00700 ; IT WON'T LOOK UP PROPERLY IF SFD BLOCK IS ALL 0'S
00710 SKIPN PPN ;WMT-SFD BLOCK IS NOT ALL 0'S
00720 SETZM LPPN ;WMT-MAKE MONITOR KNOW YOU WANT DEFAULT
00730 INLOOK: LOOKUP X,LOOKIN
00740 JRST FALSE ;## LET SOMEONE ELSE HANDLE THE ERROR
00750 JRST IRET1>
00760
00770 IRET1: ADDI B,CHOCH-1 ;WMT- POINT TO OLDCH
00780 IFE SFDFLG,<MOVEI A,SFDBLK ;WMT-IN CASE LOOKUP CHANGES LPPN
00790 MOVEM A,LPPN> ;WMT
00800 PUSH B,[0] ;oldch
00810
00820 IFN STPGAP,<
00830 PUSH B,[0] ;page number
00840 PUSH B,[0] ;line number
00850 ADDI B,COUNT+1-CHLINE ;WMT- SET B TO POINT TO FIRST LOC AFTER COUNT
00860 >
00870
00880 IFE STPGAP,<ADDI B,COUNT+1-CHOCH> ;WMT
00890 HRRM B,.JBFF
00900 JRST ININBF
00910
00920 REMOTE<
00930 ININBF: INBUF X,NIOB
00940 JRST TRUE ;## RETURN FROM GOOD LOOKUP WITH T
00950
00960
00970 ENTR:
00980 IFN SFDFLG,<
00990 LOOKIN: BLOCK 4
01000 EXT=LOOKIN+1
01010
01020 PPN=LOOKIN+3>
01030 IFE SFDFLG,<
01040 LOOKIN: Z
01050 EXT: Z
01060 Z
01070 LPPN: SFDBLK ;WMT-EXTENDED LOOKUP
01080 SFDBLK: 0,,-1 ;WMT-PATH BLOCK
01090 Z ;WMT-WORD FOR SCAN SWITCHES
01100 PPN: Z
01110 BLOCK SFDLEN
01120 Z> ;WMT-GUARANTEE ZERO
01130 >
01140 PAGE
00010 OUTPUT: PUSHJ P,CHNSUB ;get channel name
00020 PUSH P,A
00030 TLO A,400000 ;WMT-set bit for output IN LH
00040 ;WMT-RH WON'T DO IF LOW SEG>400000
00050 PUSHJ P,TABSRC ;get physical channel nuber
00060 SETZM DEV ;## CLEAR DEV FOR DEFAULT TO DSK:
00070 PUSHJ P,IOSUB ;get device and file name
00080 MOVEM A,ENTR ;file name
00090 HLLZS ENTR+1 ;%% CLEAR RIGHT HALF
00100 SETZM ENTR+2 ;zero creation date
00110 MOVE A,FPROTE(S) ;WMT-PICK UP PROTECTION DESIRED
00120 MOVEI A,-INUM0(A);WMT-GET REAL VALUE
00130 DPB A,[POINT 9,ENTR+2,8];SHOVE BOTTOM 9 BITS AS FILE PROTECTION
00140 MOVE A,CHANNEL
00150 DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
00160 DPB A,[POINT 4,OUTENT,ACFLD]
00170 DPB A,[POINT 4,OUTOBF,ACFLD]
00180 IFN RANDOM,< SETZM CHBUFS(A)> ;WMT- ZERO BUFFER COUNT
00190 HRRZ B,CHTAB(A)
00200 MOVE A,ENTR ;WMT-FILE NAMEE
00210 MOVEM A,CHFILE(B) ;WMT- SAVE IT
00220 MOVE A,ENTR+1 ;WMT-EXTENSION
00230 MOVEM A,CHEXT(B) ;WMT- SAVE IT
00240 MOVEI A,CHDAT(B)
00250 HRLM A,AOUT3+1
00260 MOVE A,DEV
00270 MOVEM A,AOUT3
00280 DEVCHR A,
00290 TLNN A,OUTB
00300 JRST AOUT.2 ;not output device
00310 TLNN A,AVLB
00320 JRST AOUT.4 ;not available
00330 JRST AOUT2
00340 REMOTE<
00350 AOUT2: INIT X,
00360 AOUT3: X
00370 X
00380 JRST AOUT.4 ;cant init
00390 IFN CHDEV-CHNAM-1,<ADDI B,CHDEV-CHNAM-1> ;WMT- IF CHDEV.NE.CHNAM+1
00400 PUSH B,DEV
00410 ;WMT- PATCH TO BYPASS MONITOR BUG WHEN LOOKING UP WITH PATH BLOCK
00420 ; THAT IS ALL ZEROES
00430 SKIPN PPN ; SKIP IF NOT ALL ZEROES
00440 SETZM LPPN ; MAKE IT DEFAULT PATH
00450 OUTENT: ENTER X,ENTR
00460 JRST OUTERR ;cant enter
00470 JRST ORET1>
00480 ORET1: ADDI B,CHLL-CHDEV-1 ;WMT- ALIGN FOR NEXT PUSH
00490 PUSH B,[LPTLL] ;linelength
00500 PUSH B,[LPTLL] ;chrct
00510 ADDI B,COUNT+1-CHHP ;WMT- POINT TO JUST AFTER COUNT
00520 HRRM B,.JBFF
00530 XCT OUTOBF
00540 REMOTE<
00550 OUTOBF: OUTBUF X,NIOB
00560 >
00570 JRST POPAJ
00580
00590 OUTERR: PUSHJ P,AIOP
00600 LDB A,[POINT 3,ENTR+1,35]
00610 CAIE A,2
00620 ERR1 [SIXBIT /DIRECTORY FULL !/]
00630 ERR2 [SIXBIT /FILE IS WRITE PROTECTED !/]
00640 PAGE
00010 IOSEL: MOVE C,-1(P)
00020 JUMPE C,CPOPJ ;tty
00030 JUMPE B,IOSELZ ;dont release
00040 IOSEL1: DPB C,[POINT 4,RLS,ACFLD]
00050 XCT RLS
00060 REMOTE<
00070 RLS: RELEASE X, ;release channel
00080 >
00090 HRRZS CHTAB(C) ;release channel table entry
00100 MOVEM 0,@CHTAB(C) ;blast channel name
00110 SETZM -1(P)
00120 IOSELZ: HRRZ C,CHTAB(C)
00130 POPJ P,
00140 PAGE
00010 INCNT: MOVEI A,NIL ;(INC NIL T)
00020 MOVEI B,TRUTH(S)
00030
00040 INC: CAMN A,INCH ;*** If trying to select the TTY and it
00050 JUMPE A,[MOVE T,[JRST TTYI] ;*** is already selected, don't bother
00060 MOVEM T,TYI2 ;WMT- IN CASE READLIST CLOBBERED IT
00070 JRST CPOPJ] ;WMT
00080 PUSH P,INCH#
00090 PUSHJ P,IOSEL
00100 JUMPN B,INC2 ;released channel
00110 SKIPN C
00120 MOVEI C,TTOCH-CHOCH ;tty deselect
00130 IFN STPGAP,<
00140 MOVEI B,CHOCH(C)
00150 HRLI B,OLDCH
00160 BLT B,CHLINE(C) ;save channel data
00170 >
00180 IFE STPGAP,<
00190 MOVE B,OLDCH
00200 MOVEM B,CHOCH(C)
00210 >
00220 JRST INC2+1
00230 INC2: SETZM INCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
00240 JUMPE A,ITTYRE ;select tty
00250 MOVE B,A
00260 PUSHJ P,TABSR1 ;determine physical channel number
00270 JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
00280 HRRZM A,INCH
00290 DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
00300 DPB A,[POINT 4,TYI2Y,ACFLD]
00310 DPB A,[POINT 4,TYI2Z,ACFLD]
00320 HRRZ A,CHTAB(A)
00330 MOVEI T,COUNT(A)
00340 HRLI T,(SOSG)
00350 MOVEI B,POINTR(A)
00360 HRRM B,TYI3 ;set up tyi parameters
00370 HRRM B,TYI3A
00380 IFN RANDOM,<
00390 MOVEI B,CHBUFS(A) ;WMT-SET TO INCREMENT BUFFER COUNT
00400 HRRM B,TYI2W>
00410 INC3:
00420 IFN STPGAP,<
00430 MOVSI B,CHOCH(A)
00440 HRRI B,OLDCH
00450 BLT B,LINUM ;restore channel data
00460 >
00470 IFE STPGAP,<
00480 MOVE B,CHOCH(A)
00490 MOVEM B,OLDCH
00500 >
00510 MOVEM T,TYI2
00520 IOEND: POP P,A
00530 JUMPE A,CPOPJ
00540 MOVE A,CHTAB(A) ;get channel name
00550 HRRZ A,(A)
00560 POPJ P,
00570
00580 ITTYRE: SETZM INCH
00590 MOVE T,[JRST TTYI] ;reselect tty
00600 MOVEI A,TTOCH-CHOCH
00610 JRST INC3
00620 ;*** RETURN CURRENT INPUT CHANNEL
00630 GETICH: MOVE A,INCH
00640 JRST IOEND+1
00650 PAGE
00010 OUTCNT: MOVEI A,0 ;(outc nil t)
00020 MOVEI B,1
00030
00040 OUTC: CAMN A,OUTCH ;*** If trying to select the TTY and it
00050 JUMPE A,CPOPJ ;*** is already selected, don't bother
00060 PUSH P,OUTCH#
00070 PUSHJ P,IOSEL
00080 JUMPN B,OUTC2 ;closed this file
00090 SKIPN C
00100 MOVEI C,TTOLL-CHLL ;tty deselect
00110 MOVE B,CHCT
00120 MOVEM B,CHHP(C) ;save channel data
00130 MOVE B,LINL
00140 MOVEM B,CHLL(C)
00150 JRST OUTC2+1
00160λ∂uTC2: SETZM OUTCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
00170 JUMPE A,OTTYRE ;return to tty
00180 TLO A,400000 ;WMT-set output bit
00190 MOVE B,A
00200 PUSHJ P,TABSR1 ;determine physical channel number
00210 JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
00220 DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
00230 HRRZM A,OUTCH
00240 HRRZ A,CHTAB(A)
00250 MOVEI B,POINTR(A)
00260 HRRM B,TYO5 ;set up tyo2 parameters
00270 MOVEI T,COUNT(A)
00280 HRLI T,(SOSG)
00290 IFN RANDOM,<
00300 MOVEI B,CHBUFS(A) ;WMT-SET TO INCREMENT BUFFER LOADS
00310 HRRM B,TYO2W>
00320 OUTC3: MOVE B,CHLL(A)
00330 MOVEM B,LINL
00340 MOVE B,CHHP(A)
00350 MOVEM B,CHCT
00360 MOVEM T,TYOD
00370 JRST IOEND
00380
00390 OTTYRE: SETZM OUTCH
00400 MOVE T,[JRST TTYO]
00410 MOVEI A,TTOLL-CHLL ;tty reselect
00420 JRST OUTC3
00430 ;*** RETURN CURRENT OUTPUT CHANNEL
00440 GETOCH: MOVE A,OUTCH
00450 JRST IOEND+1
00460 PAGE
00010 AOUT.2:
00020 AIN.2: PUSHJ P,AIOP
00030 ERR2 [SIXBIT /ILLEGAL DEVICE!/]
00040 AOUT.4:
00050 AIN.4: PUSHJ P,AIOP
00060 ERR2 [SIXBIT /DEVICE NOT AVAILABLE !/]
00070 AIN.7:
00080 IFN SFDFLG,<PUSHJ P,AIOP>
00090 IFE SFDFLG,<PUSHJ P,AIOP1>
00100 ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
00110
00120 AIN.8: SIXBIT /INPUT ERROR!/
00130
00140 AIOP1: MOVE A,INCH
00150 PUSHJ P,IOEND+1
00160 PUSHJ P,CHNPTH
00170 JRST EPRINT
00180
00190 AIOP: MOVE A,DEVDAT
00200 JRST EPRINT
00210 PAGE
00010 ; RANDOM I/O FUNCTIONS
00020
00030 IFN RANDOM,<
00040 ; GTOPOS GETS THE POSITION OF THE CHARACTER ABOUT TO BE OUTPUT.
00050 ; GTIPOS GETS THE POSITION OF THE CHARACTER ABOUT TO BE INPUT.
00060 ; THEY RETURN A NUMBER CORRESPONDING TO THE BYTE POSITION OF THE
00070 ; CHARACTER IN THE FILE.
00080 ; SETPOS SETS THE POSITION OF THE INPUT CHANNEL TO INPUT THE
00090 ; CHARACTER IN THE BYTE POSITION INDICATED BY IT'S ARG.
00100 GTOPOS: SKIPA A,OUTCH ;WMT-GET POSITION ON OUTPUT CHANNEL
00110 GTIPOS: MOVE A,INCH ;WMT-GET POSITION OF INPUT CHANNEL
00120 JUMPE A,CPOPJ ;WMT- EXIT IF TTY:
00130 HRRZ A,CHTAB(A)
00140 MOVE B,CHBUFS(A) ;WMT-# OF BUFLOADS
00150 SUBI B,1
00160 IMULI B,BFCHRS ;WMT-GET TO CHARACTERS
00170 PUSH P,B ;WMT- SAVE FOR A WHILE
00180 SKIPGE B,CHDAT(A) ;WMT- GET THE POSITION OF HEAD OF BUFFER
00190 JRST NODAT ;WMT- BUT LOOK OUT FOR UNLOADED BUFFER
00200 PUSHJ P,GTCPOS ;WMT- GET BYTE POSITION IN BUFFER
00210 NODAT1: POP P,A ;WMT- GET CHARS IN PREVIOUS BUFFERS
00220 ADD A,C ;WMT- COMPUTE TOTAL CHARS.
00230 JRST MAKNUM
00240 NODAT: SETZB C,0(P) ;WMT- CLEAR ALL IF NO BUFFER LOADED
00250 JRST NODAT1 ;WMT- AND CLEAN UP (RETURN 0)
00260
00270 SETPOS: PUSH P,A ;WMT-SAVE ARGUMENT
00280 PUSHJ P,NUMVAL ;WMT-GET NUMERIC VALUE OF ARG
00290 MOVE B,A
00300 MOVE A,INCH ;WMT-DO IT ON INPUT CHANNEL
00310 JUMPE A,POPBJ ;WMT-RETURN NIL IF ON TTY:
00320 HRRZ A,CHTAB(A)
00330 SETZM CHOCH(A) ;WMT- CLEAR OUT OLD CHAR.
00340 IDIVI B,BFCHRS ;WMT-GO BACK TO BUFFERLOADS.
00350 PUSH P,C ;WMT-SAVE EXCESS BYTES
00360 ADDI B,1 ;WMT- FIRST BUFFER IS 1
00370 CAMN B,CHBUFS(A) ;WMT-CHECK TO SEE IF AT RIGHT BUFFER
00380 SKIPGE C,CHDAT(A) ;WMT- WATCH OUT FOR EMPTY BUFFER
00390 JRST STUPOS ;WMT- GO DO USETI
00400 MOVE B,C ;WMT- FOR GTCPOS
00410 PUSHJ P,GTCPOS ;WMT- GET CHANNEL BYTE POSITION
00420 MOVE A,INCH ;WMT- CHANNEL NUMBER
00430 MOVE A,CHTAB(A) ;WMT- CHANNEL INFO
00440 ADDM C,COUNT(A) ;WMT- UNDO BACK TO BEGINNING OF BUFFER
00450 MOVE B,CHDAT(A) ;WMT- POINTER TO BUF.HEADER
00460 ADDI B,1 ;WMT- POINT TO WORD BEFORE BUF. STORAGE
00470 HRLI B,00700 ;WMT- POINT TO ZEROTH BIT POSITION
00480 MOVEM B,POINTR(A) ;WMT-POINT BEFORE ALL DATA
00490
00500 USETIR: MOVE B,COUNT(A) ;WMT-PICK UP NUMBER OF CHARS READ
00510 POP P,C ;WMT- RETRIEVE CHARS IN THIS BUFFER
00520 SUB B,C ;WMT- KNOCK OFF THIS NUMBER
00530 ADDI B,1 ;WMT- ALIGN IT RIGHT
00540 MOVEM B,COUNT(A) ;WMT- AND RESTORE IT
00550 MOVE B,C
00560 IDIVI B,5 ;WMT-COMPUTE WORDS, CHARS
00570 ;WMT- PRESUME POINTER POINTS TO START OF BUFFER -1
00580 ADDI B,1
00590 ADDM B,POINTR(A) ;WMT-POINT TO RIGHT WORD
00600 IMULI C,7
00610 MOVNS C
00620 ADDI C,44 ;WMT- GET TO RIGHT POSITION
00630 DPB C,[POINT 6,POINTR(A),5] ;WMT- DEPOSIT IN POINTER
00640 JRST POPAJ ;WMT-RETURN ARGUMENT
00650
00660 STUPOS: MOVEM B,CHBUFS(A) ;WMT-SAVE BUFFER LOADS
00670 HRRM B,USETIX ;WMT- TELL USETI HOW MUCH TO DO
00680 MOVE C,INCH ;WMT- GET INPUT CHANNEL
00690 DPB C,[POINT 4,USETIX,ACFLD] ;WMT-SET USETI UP FOR CHANNEL
00700 DPB C,[POINT 4,USETIY,ACFLD]
00710 DPB C,[POINT 4,USETIZ,ACFLD]
00720 JRST USETIX ;WMT- GO POSITION AND INPUT FILE
00730 REMOTE<
00740 USETIX: USETI X,X ;WMT- POSITION FILE
00750 USETIY: INPUT X, ;WMT- DO INPUT
00760 USETIZ: STATZ X,740000 ;WMT- INPUT ERROR?
00770 ERR2 AIN.8 ;WMT- YES
00780 JRST USETIR
00790 >
00800
00810 ; GTCPOS COMPUTES BYTE POSITION WITHIN THE BUFFER
00820 GTCPOS: ADDI B,2 ;WMT- HEAD OF BUFFER IS HERE
00830 HRRZ C,POINTR(A) ;WMT-SEE WHERE IT POINTS
00840 SUB C,B ;WMT- INTO BUFFER
00850 IMULI C,5 ;WMT-CONVERT INTO CHARS.
00860 SKIPE CHOCH(A) ;WMT-SEE IF ANY EXTRAS
00870 SUBI C,1 ;WMT- TAKE CARE OF IT
00880 LDB A,[POINT 6,POINTR(A),5] ;WMT- UPDATE POINTER
00890 MOVNS A
00900 ADDI A,44 ;WMT- COMPUTE BYTE POSITION
00910 IDIVI A,7
00920 ADD C,A ;WMT- COMPUTE POSITION IN THIS BUFFER
00930 POPJ P, ;WMT- RETURN BYTES ALREADY PROCESSED
00940 >
00950 PAGE
00010
00020 SUBTTL QMANGR INTERFACE
00030
00040 ;## CODE TO ALLOW LISP USER'S TO CALL DEC'S QMANGR, ALLOWING
00050 ;## PRINTING OF FILES AND CREATION OF JOBS
00060 ;## SCANS ARG LIST SETTING UP THE APPROPRIATE PARAMETERS. IT
00070 ;## SAVE THE PDLS, SWAPS HI-SEGS FOR SYS:QMANGR AND
00080 ;## DOES A PUSHJ TO 400010. IT ALSO CHANGES .JBREN SO
00090 ;## THAT THE USER CAN RECOVER IN CASE OF QMANGR ERRORS.
00100 ;## ST WILL ALSO STILL WORK. REG 17 (SP) IS USED AS QMANGR'S
00110 ;## PDL. CORE IS CONTRACTED AFTER RETURN FROM QMANGR AND QUEUE
00120 ;## RESTORES APPROPRIATE REGS AND RETURNS NIL. ALTHOUGH
00130 ;## CODE FOR EXTENDED SWITCHES IS INCLUDED, MOST OF
00140 ;## IT IS TURNED OFF. USE AT YOUR OWN RISK. NOTE THAT
00150 ;## /LIST, /AFTER AND /DEAD REQUIRE SPECIAL CODE
00160 ;## THAT IS NOT INCLUDED. SEE APPROPRIATE
00170 ;## DEC DOCUMENTATION FOR FURTHER INFO. 6/12/73
00180
00190
00200 IFN QALLOW <
00210 IFNDEF QSWEXT <QSWEXT=0> ;## IF NOT DEFINED THEN DEFAULT IS NO EXTENDED
00220 IFE QSWEXT <NSWS==QTABL1>;## NUMBER OF ALLOWED SWITCHES
00230 IFN QSWEXT <NSWS==QTABL2>;## LENGTH OF EXTENDED TABLE
00240 IFNDEF QLSTOK <QLSTOK==0>
00250 IFNDEF QTIME <QTIME==0>
00260
00270
00280 ;%% THE FOLLOWING CODE IS AN ILLUSTRATION OF HOW
00290 ;%% EASY IT IS TO LOSE TRYING TO INTERFACE TO
00300 ;%% DEC SOFTWARE. THE FOLLOWING DEFINITIONS ALLOW
00310 ;%% TOO FEW WORDS FOR THE CURRENT FILE PARAMETER
00320 ;%% AREA; SEE THE DEFINITIONS AS COPIED FROM
00330 ;%% THE QMANGR SOURCE BELOW.
00340 COMMENT &
00350 INPPAR==32 ;## NUMBER OF WORDS IN INP AREA FOR INPUT REQUEST
00360 OUTPAR==24 ;## NUMBER WORDS IN MAIN AREA FOR OUTPUT REQUEST
00370 DIFPAR==INPPAR-OUTPAR ;## DIFFERENCE IN LENGTHS FOR MAIN AREA TYPES
00380 FILPAR==14 ;## NUMBER WORDS IN FILE PARAMTER AREA
00390
00400
00410
00420
00430 ;## LOCATIONS IN PARAMETER AREAS
00440 ;## MAIN AREA
00450 Q.MEM==0 ;## MEMORY FOR QMANGR
00460 Q.OPR==1 ;## REQUESTED OPERATION
00470 Q.LEN==2 ;## RH=NUMBER OF FILES IN REQUEST
00480 Q.DEV==3 ;## REQUESTED QUEUE
00490 Q.PPN==4 ;## PPN REQUESTING
00500 Q.JOB==5 ;## JOB NAME
00510 Q.SEQ==6 ;## JOB SEQUENCE #
00520 Q.PRI==7 ;## EXTERNAL PRIORITY
00530 Q.PDEV==10 ;##
00540 Q.TIME==11 ;##
00550 Q.CREA==12 ;##
00560 Q.AFTR==13 ;## AFTER PARAMETER
00570 Q.DEAD==14 ;## DEADLINE PARAMETER
00580 Q.CNO==15
00590 Q.USER==16 ;## AND 17
00600 ;## INPUT SECTION OF MAIN PARAMETER AREA
00610 Q.IDEP==20 ;## RESTART AND DEPENDENCY PARAMTERS
00620 Q.ILIM==21 ;## CORE AND CPU, +1 IS LPT LIMIT AND CDP LIMIT
00630 ;## +2 IS PTP LIMIT AND PLOT LIMIT
00640 Q.IDDI==24 ;## THRU 31
00650 Q.IEND==31 ;## LAST LOC OF INP AREA
00660 ;## OUTPUT SEECTION OF MAIN PARAMETER AREA
00670 Q.OFRM==20 ;## FORM PARAMTER
00680 Q.OSIZ==21 ;## LH=LIMIT
00690 Q.ONOT==22
00700 Q.OEND==23 ;## LAST LOC OF OUTPUT AREA
00710 ;## FILE PARAMETER AREA (ONE FOR EACH FILE)
00720 Q.FSTR==0 ;## FILE STRUCTURE
00730 Q.FDIR==1 ;## THRU 6, DIRECTORY
00740 Q.FNAM==7 ;## FILE NAME
00750 Q.FEXT==10 ;## FILE EXTENSION
00760 Q.FRNM==11 ;## RENAME NAME (0)
00770 Q.FBIT==12
00780 Q.FMOD==13 ;## SPACING, FILE DISPOSAL, COPIES
00790 & ;%% END OF DELETED DEFINITIONS
00800
00810 ;%% THE FOLLOWING ARE AS COPIED FROM QMANGR (VERSION 34)
00820 ;%% ON 24 OCTOBER 1973
00830
00840 QDEFST==. ;%% WHERE TO RELOC TO AFTERWARDS
00850 RELOC 0 ;%% TO SAVE CORE AND AVOID CONFUSION
00860 ;%% COMMENTS BELOW ARE AS COPIED
00870 ;%% FROM QMANGR
00880 PHASE 0
00890 Q.ZER:! ;START OF QUEUE PARAMETER AREA
00900 Q.MEM:! BLOCK 1 ;HOLD XWD WINDOW BLOCK,WINDOW WORD INDEX
00910 Q.OPR:! BLOCK 1 ;OPERATION CODE
00920 QO.CRE==1 ;CREATION OPERATION
00930 QO.LST==4 ;LIST OPERATION
00940 QO.MOD==5 ;MODIFY OPERATION
00950 QO.KIL==6 ;KILL OPERATION
00960 QO.DEL==10 ;DELETE OPERATION
00970 QO.REQ==11 ;REQUEUE OPERATION
00980 QO.FLS==12 ;FAST LIST OPERATION
00990 Q.LEN:! BLOCK 1 ;LENGTHS IN AREA
01000 Q.DEV:! BLOCK 1 ;DESTINATION DEVICE
01010 Q.PPN:! BLOCK 1 ;PPN ORIGINATING REQUEST
01020 Q.JOB:! BLOCK 1 ;JOB NAME
01030 Q.SEQ:! BLOCK 1 ;JOB SEQUENCE NUMBER
01040 Q.PRI:! BLOCK 1 ;EXTERNAL PRIORITY
01050 Q.PDEV:! BLOCK 1 ;PROCESSING DEVICE
01060 Q.TIME:! BLOCK 1 ;PROCESSING TIME OF DAY
01070 Q.CREA:! BLOCK 1 ;CREATION TIME
01080 Q.AFTR:! BLOCK 1 ;AFTER PARAMETER
01090 Q.DEAD:! BLOCK 1 ;DEADLINE TIMES
01100 Q.CNO:! BLOCK 1 ;CHARGE NUMBER
01110 Q.USER:! BLOCK 2 ;USER'S NAME
01120
01130 Q.I:! ;START OF INPUT QUEUE AREA
01140 Q.IDEP:! BLOCK 1 ;DEPENDENCY WORD
01150 Q.ILIM:! BLOCK 3 ;JOB LIMITS
01160 Q.IL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
01170 Q.IDDI:! BLOCK 6 ;JOB'S DIRECTORY
01180 Q.II:! ;START OF INPUT FILES AREA
01190
01200 PHASE Q.I
01210 Q.O:! ;START OF OUTPUT QUEUE AREA
01220 Q.OFRM:! BLOCK 1 ;FORMS REQUEST
01230 Q.OSIZ:! BLOCK 1 ;LIMIT WORD
01240 Q.OL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
01250 Q.ONOT:! BLOCK 2 ;ANNOTATION
01260 Q.FF:!
01270 PHASE 0
01280 Q.F:! ;DUPLICATED AREA FOR EACH REQUESTED FILE
01290 Q.FSTR:! BLOCK 1 ;FILE STRUCTURE
01300 Q.FDIR:! BLOCK 6 ;ORIGINAL DIRECTORY
01310 Q.FNAM:! BLOCK 1 ;ORIGINAL NAME
01320 Q.FEXT:! BLOCK 1 ;ORIGINAL EXTENSION
01330 Q.FRNM:! BLOCK 1 ;RENAMED FILE NAME (0 IF NOT)
01340 Q.FBIT:! BLOCK 1 ;BIT 0=PRESERVED BY QUEUE, REST=STARTING BIT
01350 Q.FMOD:! BLOCK 1 ;FILE SWITCHES
01360 X.LOG==1B1 ;FILE IS LOG FILE
01370 X.NEW==1B2 ;OK IF FILE DOESNT EXIST YET
01380 Q.FRPT:!BLOCK 2 ;/REPORT
01390
01400 Q.FLEN==.-Q.F
01410 DEPHASE
01420 PHASE 0
01430 Q.FDRM:! BLOCK 6 ;DIRECTORY MASK FOR MODIFY
01440 Q.FNMM:! BLOCK 1 ;FILE NAME MASK FOR MODIFY
01450 Q.FEXM:! BLOCK 1 ;EXTENSION MASK FOR MODIFY
01460 Q.FMDM:! BLOCK 1 ;MODIFIER MASK FOR MODIFY
01470 Q.FMLN==.-Q.F ;LENGTH OF MODIFY BLOCK
01480
01490 DEPHASE
01500 RELOC QDEFST ;%% MAKE UP FOR INCREASE IN LOCATION
01510 ;%% COUNTER
01520
01530 INPPAR==Q.II ;%% SIZE OF MINIMUM INPUT AREA
01540 OUTPAR==Q.FF ;%% SIZE OF MINIMUM OUTPUT AREA
01550 OUTPR1==OUTPAR-1 ;%% MACRO DOESN'T LIKE EXPRESSIONS
01560 DIFPAR==INPPAR-OUTPAR ;%% DIFFERENCE IN AREAS
01570 FILPAR==Q.FLEN ;%% FILE DATA AREA
01580 LOWLEN==↑D110 ;## AREA NEED FOR PARAMETER
01590 ;## AREA TO QMANGR
01600 LHLEN==OUTPR1*1B26+FILPAR ;## LH OF Q.LEN DEFAULTS
01610 NQS==6 ;## NUMBER OF QUEUES
01620
01630
01640 ;## QUEUE ERRORS
01650
01660 QILLSW: HLRZ A,(T) ;## GET SWITCH THAT CAUSED ERROR
01670 PUSHJ P,PRINT
01680 STRTIP [SIXBIT / =ILL. SWITCH SPEC.!/]
01690 PUSHJ P,CONCOR ;## SAVE THAT CORE
01700 QERR1: ERR2 [SIXBIT /ERROR IN QUEUE REQUEST!/]
01710
01720
01730
01740 QUEUE: SKIPN T,A ;## ERROR IF NO ARGS
01750 JRST QERR1
01760 PUSHJ P,DEVCHK ;## SEE IF QUEUE SPECIFIED
01770 JUMPE A,NOQUE ;## IF A=0 THEN NOT A QUEUE
01780 JUMPE B,NOQUE ;## IF B=0 THEN NOT A QUEUE
01790 MOVE AR2A,A
01800 HLRZ B,A ;## GET FIRST THREEE LETTERS
01810 MOVEI C,NQS ;## GET NUMBER OF PERMISSIBLE QUEUES
01820 SOJL C,NOQUE ;## IF EXHAUSTED TABLE, THEN NO QUEUE
01830 MOVE A,QSTABL(C) ;## PERMISSIBLE QUEUES
01840 JSP R,CHKGO ;## JUMP TO ROUTINE THAT COMPARES RH AND GO
01850 ;## TO LH OF A IFF RH(A)=B
01860 JRST .-3 ;## LOOP
01870
01880
01890
01900 ;## TABLE OF PERMISSIBLE QUEUES AND WHERE TO GO ON EACH
01910
01920 QSTABL: XWD INPREQ, 'INP'
01930 XWD OUTREQ, 'LPT'
01940 XWD OUTREQ, 'PTP'
01950 XWD OUTREQ, 'PTP'
01960 XWD OUTREQ, 'CDP'
01970 XWD OUTREQ, 'PLT'
01980
01990 OUTREQ: TDZA A,A ;## HERE TO PROCESS OUTPUT REQUEST(CLEAR A)
02000 INPREQ: MOVEI A,DIFPAR ;## HERE TO PROCESS INPUT REQUEST
02010 JRST QGOOD ;## FOUND A QUEUE
02020 NOQUE: MOVSI AR2A,'LPT' ;## HERE IF NO QUEUE, DEFAULT=LPT
02030 TDZA A,A ;## CLEAR A AND SKIP
02040 QGOOD: HRRZ T,(T) ;## HERE IF QUEUE SPECIFIED
02050 ADDI A,OUTPAR ;## A IS ZERO OR INPPAR
02060 QSETUP: PUSH P,B ;## B CONTAINS THREE LETTERS(OR BLANK). SAVE IT
02070 HRLZI TT,(A) ;## SAVE LNENGTH OF AREA
02080 PUSHJ P,TEMCOR ;## EXPAND CORE
02090 HRRI TT,(A) ;## START ADDR OF MAIN AREA
02100 MOVE A,TT
02110 PUSHJ P,CLRBLK ;## CLEAR AREA
02120 MOVEM AR2A,Q.DEV(TT)
02130 MOVEI C,LHLEN ;## GET LENGTHS FOR HEADER AND FILE AREAS
02140 MOVE A,[XWD 500,500]
02150 HRLZM A,Q.OSIZ(TT) ;## ASSUME OUTPUT HERE
02160 POP P,B ;## RESTORE LEFT THREE LETTERS
02170 CAIE B,'INP' ;## WAS IT AN INPUT REQUEST?
02180 JRST QUEUE1 ;## NO SHOULD BE OK
02190 ADDI C,DIFPAR←9 ;## UPDATE HEADER LENGTH
02200 MOVEM A,Q.ILIM+1(TT) ;## MAX PAGES AND CARD PUNCH
02210 MOVEM A,Q.ILIM+2(TT) ;## MAX PAPER TAPE AND PLOTTER
02220 HRLI A,↑D256
02230 MOVEM A,Q.ILIM(TT) ;## MAX CORE AND CPU(CORMAX MAY HAVE TO BE
02240 ;## CHECKED HERE)
02250 MOVSI A,400000 ;## SET BIT 0 FOR NOT RESTARTABLE
02260 HLLZM A,Q.IDEP(TT) ;## NOT RESTARTABLE(NO DEPEND OR UNIQUENESS)
02270 QUEUE1: MOVSM C,Q.LEN(TT) ;## SET HEADER AND FILE AREA LENGTHS
02280 GETPPN A, ;## SET REQUESTING PPN
02290 CAI ;## WEIRD SKIP RETURN ON THIS UUO
02300 MOVEM A,Q.PPN(TT)
02310 SETZ REL, ;## CLEAR REG FOR FILE AREA
02320 MOVEI A,20 ;## PRIORITY DEFAULT
02330 MOVEM A,Q.PRI(TT)
02340 AOSA Q.OPR(TT) ;## SET DEFAULT FOR REQUEST TYPE=/CREATE
02350 ;## BASIC LOOP FOR HANDLING THE SWITCHES
02360
02370 QLOOP: HRRZ T,(T) ;## HERE IF ROUTINE DID NOT MOVE ARG
02380 QSELF: JUMPE T,QDONE
02390 PUSHJ P,DEVCHK ;## SEE IF DEVICE OR ATOMIC FILE NAME?
02400 JUMPN B,QFILEA ;## IF B#0 THEN DEVICE
02410 JUMPN A,QFILE ;## IF A#0 THEN ATOMIC FILE
02420 HLRZ C,(T) ;## WELL, SEE IF SWITCH
02430 HRRZ A,(C) ;## CDAR
02440 PUSHJ P,ATOM ;## ATOM?
02450 JUMPN A,QFILE ;## YES, THEREFORE(FILE.EXT)
02460 HLRZ B,(C) ;## CAAR
02470 SUBI B,(S) ;## STRIP OFF RELOCATION
02480 HRRZI C,NSWS ;## GET NUMBER OF SWITCHES
02490 QLOOP1: SOJL C,QFILE ;## IF NO SWITCH, GO QFILE
02500 MOVE A,QTABLE(C) ;## GET MEMBER OF TABLE
02510 JSP R,CHKGO
02520 JRST .-3 ;## LOOP
02530
02540
02550 ;## DISPATCH TABLE FOR SWITCHES
02560
02570 QTABLE:
02580 PHASE 1
02590 XWD QCOPIE,COPIES ;## /COPIES
02600 XWD QCPU,CPU ;## /CPU
02610 XWD QFORMS,FORMS ;## /FORMS
02620 XWD QLIMIT,LIMIT ;## /LIMIT
02630 QTABL1: XWD QDISP,DISP ;## /DISP (FILE DISPOSITION)
02640
02650 ;## EXTENDED SWITCHES
02660
02670 IFN QSWEXT <
02680 IFE QLSTOK <XWD QILLSW, LISTAT>
02690 IFN QLSTOK <XWD QLIST, LISTAT>
02700
02710 IFE QTIME <
02720 XWD QILLSW,AFTER ;## /AFTER ILLEGAL (SEE ABOVE)
02730 XWD QILLSW,DEAD ;## /DEAD (DEADLINE)
02740 >
02750
02760 IFN QTIME <
02770 XWD QAFTR,AFTER
02780 XWD QDEAD,DEAD
02790 >
02800 XWD QCORE,COREAT
02810 XWD QMOD,MODIFY ;## /MODIFY
02820 XWD QKILL,KILL ;## /KILL
02830 XWD QJOB,JOB ;## /JOB
02840 XWD QDEPND,DEPEND ;## /DEPEND
02850 XWD QRSTR,RSTRT ;## /RESTART
02860 XWD QUNIQ,UNIQUE ;## /UNIQUE
02870 XWD QCORE,COREAT ;## /COREE
02880 XWD QPAGES,PAGES ;## /PAGES
02890 XWD QPLOT,PLOT ;## /PLOT
02900 XWD QPTAPE,PTAPE ;## /PTAPE
02910 XWD QCARDS,CARDS ;## /CARDS
02920 XWD QSEQ,SEQ ;## /SEQ
02930 XWD QPRIOR,PRIOR ;## /PRIOR (PRIORITY)
02940 XWD QSPACE,SPACE ;## /SPACE (SPACING)
02950 XWD QLIMIT,LIMIT ;## /LIMIT
02960 QTABL2: XWD QHEAD,HEAD ;## /HEAD (HEADERS)
02970 >
02980 DEPHASE
02990
03000 ;## DISPATCHING THE VARIOUS SWITCHES
03010
03020 IFN QSWEXT <QLIST: HRRZI A,4 ;## HERE FOR LIST REQUEST
03030 CAIA
03040 QMOD: HRRZI A, 5 ;## /MODIFY
03050 CAIA
03060 QKILL: HRRZI A, 6 ;## /KILL
03070 HRRZM A, Q.OPR(TT)
03080 JRST QLOOP
03090 >
03100
03110 ;## INPUT QUEUE ONLY SWITCHES
03120 ;## PUTS BYTE POINTER INTO B AND THEN CHECKS TO SEE IF SWITCH VALID IN
03130 ;## THIS CONTEXT (I.E. ARE WE PROCESSING AN INPUT REQUEST?)
03140 ;## IF NOT VALID, SKIPS THE SWITCH(MAY BE CHANGED LATER)
03150
03160 IFN QSWEXT <
03170 QPLOT: JSP R,RINPCH
03180 AOJA B, QCARD+1
03190 QPTAPE: JSP R, LINPCH
03200 AOJA B, .+4
03210 QCARDS: JSP R, RINPCH
03220 AOJA B, .+4
03230 QPAGES: JSP R, LINPCH
03240 AOJA B, .+4
03250 >
03260
03270 QCPU: JSP R, RINPCH
03280 AOJA B,QARG
03290
03300
03310 IFN QSWEXT <
03320 QCORE: JSP R, LINPCH
03330 AOJA B,QARG
03340 QDEPND: JSP R, RINPCH
03350 JRST QARG
03360 >
03370
03380 ;## OUTPUT QUEUE ONLY SWITCHES
03390 QFORMS: JSP R, OUTCHK
03400 PUSH P,QSXARG ;## CONVERT ARG TO SIXBIT
03410 MOVEM A, Q.OFRM(TT) ;## MAKE SIXBIT IF FORMS
03420 JRST QLOOP
03430 QLIMIT: JSP R, OUTCHK
03440 MOVE B,LINP
03450 AOJA B,QARG
03460
03470 OUTCHK: HLRZ A,Q.DEV(TT) ;## GET REQUEST TYPE (THREE LETTERS)
03480 CAIE A,'INP' ;## ERROR IF INPUT REQUEST
03490 JRST (R)
03500 JRST QILLSW
03510
03520 QCOPIE: JSP R, FILECH ;## CHECK IF WE HAVE SET UP A FILE AREA
03530 MOVE B,[POINT 6,Q.FMOD(REL),35] ;## BYTE POINTER
03540 JRST QARG
03550
03560
03570 ;## FOR DISPOSITION, 1=PRESERVE, 2=RENAME, 3=DELETE,
03580 ;## FIRST THREE LETTERS OF ARG TO SWITCH UNIQUELY IDENTIFY
03590 ;## ILLEGAL ARG CAUSES ERROR
03600 QDISP: JSP R,FILECH ;## BE SURE FILE AREA SET UP
03610 PUSHJ P,QSXARG ;## MAKE ARG SIXBIT
03620 HLRZ C,A ;## GET FIRST THREE LETTERS
03630 SETZ A, ;## CLEAR A
03640 CAIN C,'DEL' ;## DELETE AFTER OUTPUT!
03650 AOJA A,.+2 ;## YES!
03660 CAIN C,'REN' ;## RENAME FILE OUT OF UFD?
03670 AOJA A,.+3
03680 CAIE C,'PRE' ;## PRESERVE IT
03690 JRST QILLSW ;## HERE IF BAD ARGUMENT
03700 ADDI A,1
03710 MOVE B, [POINT 3, Q.FMOD(REL), 29]
03720 JRST QARG+1 ;## ARG ALREADY IN A
03730 ;## HERE WHEN SWITCH DETERMINED AND BITE POINTER IN B
03740 QGTARG: MOVEI A,(T)
03750 PUSHJ P,CADAR
03760 SUBI A,INUM0 ;## ARG SHOULD BE AN INUM
03770 POPJ P,
03780 QARG: PUSHJ P,QGTARG ;## GET ARGUMENT
03790 DPB A,B ;##
03800 JRST QLOOP ;## ALWAYS RETURN TO QLOOP
03810
03820 ;## HERE TO SEE IF INP QUEUE FOR EXTENDED PART OF MAIN AREA
03830
03840 LINPCH: MOVE B,LINP ;## GET LH BITE POINTER
03850 CAIA
03860 RINPCH: MOVE B,RINP ;## GET RH BITE POINTER
03870 HLRZ A,Q.DEV(TT) ;## GET QUEUE SPEC
03880 CAIN A,'INP' ;## INP?
03890 JRST (R) ;## YES
03900 JRST QILLSW
03910 LINP: POINT 18, Q.IDEP(TT),17 ;## BYTE POINTER FOR LEFT HALF OF EXTENDED MAIN AREA
03920 RINP: POINT 18, Q.IDEP(TT),35 ;## BYTE POINT FOR RH OF EXTENDED MAIN AREA
03930
03940
03950 ;## HERE TO BE SURE FILE AREA HAS BEEN SET UP
03960
03970 FILECH: JUMPN REL,(R) ;## REL NONZERO IF FILE AREA SET UP
03980 PUSH P,R
03990 JRST FILARE
04000 ;## HERE TO FIND FILE SPECIFICATION
04010
04020
04030 QFILEA: HRRZ T,(T) ;## GET CDR
04040 IFN SFDFLG,< SETZ B, ;## CLEAR B
04050 JRST QFILEB>
04060 IFE SFDFLG,<JRST QFILED> ;WMT-USE DEFAULT PATH
04070 IFN SFDFLG,<
04080 QFILE: MOVSI A,'DSK' ;## DEFAULT IS DSK
04090 CAIE REL,0 ;## AREA SET UP?
04100 SKIPA A,Q.FSTR(REL) ;## GET CURRENT DEVICE
04110 SKIPA B,Q.PPN(TT) ;## GET USER'S PPN IF NOT SET UP
04120 MOVE B,Q.FDIR(REL) ;## GET CURRENT PPN
04130 QFILEB: MOVEM B,PPN ;## SET PPN
04140 MOVEM A,DEV> ;## HANG ON TO DEVICE
04150
04160 IFE SFDFLG,<
04170 QFILE: JUMPE REL,QFILEC ;WMT-AREA SET UP?
04180 MOVE A,Q.FSTR(REL) ;WMT-NO, GET DEVICE
04190 MOVE B,[XWD Q.FDIR,PPN] ;WMT-MOVE PATH IN
04200 ADDI B,(REL) ;WMT-INDEX
04210 BLT B,PPN+SFDLEN ;WMT-MOVE THEM IN
04220 JRST QFILEB
04230 QFILEC: MOVSI A,'DSK' ;WMT-DEFAULT DEVICE
04240 QFILED: SETZM PPN ;WMT-USE DEFAULT PATH
04250 QFILEB: MOVEM A,DEV>
04260
04270 JUMPE T,QSELF ;## IF NIL THEN DONE
04280 PUSHJ P,NXTIO ;## FAKE IOSUB SEQUENCE
04290 PUSHJ P,IOPPN
04300 PUSH P,A ;## IOPPN RETURNS FILE NAME IN A
04310 CAIE REL,0 ;## AREA SET UP?
04320 SKIPE Q.FNAM(REL) ;## AREA SET UP, BUT NO FILE NAME?(PRECEDING SWITCHES)
04330 PUSHJ P,FILARE ;## SET UP AREA
04340 MOVE A,DEV ;## GET DEVICEE
04350 MOVEM A,Q.FSTR(REL) ;## SET FILE STRUCTURE
04360 MOVE A,EXT ;## GET EXTENSION
04370 MOVEM A,Q.FEXT(REL) ;## SET IT
04380 IFN SFDFLG,<
04390 MOVE A,PPN ;## GET PPN
04400 MOVEM A,Q.FDIR(REL)>
04410 IFE SFDFLG,<
04420 MOVE A,[XWD PPN,Q.FDIR] ;WMT-MOVE IT ALL IN
04430 ADDI B,(REL) ;WMT-INDEX
04440 BLT A,Q.FDIR+SFDLEN(REL)>
04450 ;## SET IT(DIRECTORY)
04460 POP P,Q.FNAM(REL) ;## RESTORE NAME
04470 JRST QSELF ;## T HAS BEEN RESET BY IO ROUTINES!
04480
04490
04500
04510 ;## HERE TO SET UP FILE AREA
04520
04530
04540 FILARE: AOS Q.LEN(TT) ;## ADD ONE TO NUMBER FILES IN REQUEST
04550 HRLZI A,FILPAR
04560 ADD TT,A ;## ADD TO LENGTH OF PARAMETER AREA
04570 HRRZI A,FILPAR
04580 PUSHJ P,EXPCOR
04590 JUMPE REL,FILDEF ;## SET DEFAULST IF NO PREVIOUS FILE AREA
04600 HRL A,REL
04610 HRRZI B,(A) ;## SET UP FOR BLT OF PREVIOUS AREA
04620 ADDI B,FILPAR-1 ;## FINAL DESTINATION ADDRESS
04630 HRRZI REL,(A) ;## NEW FILE AREA
04640 BLT A,(B)
04650 SETZM Q.FNAM(REL)
04660 POPJ P,
04670 FILDEF: HRRZI REL,(A)
04680 HRLI A,FILPAR
04690 PUSHJ P,CLRBLK
04700 HRLZI A,'DSK'
04710 MOVEM A,Q.FSTR(REL)
04720 MOVE A,[EXP 1B5+1B20+1B26+1B29+1] ;## DEFAULTS FOR Q.FMOD
04730 MOVEM A,Q.FMOD(REL)
04740 POPJ P,
04750
04760 ;## HERE WHEN FINISHED
04770
04780
04790 QDONE: MOVE AR1,OUTPAR+Q.FNAM(TT) ;## GET FIRST FILE NAME
04800 HLRZ A,Q.DEV(TT) ;## GET FIRST THREE LETTERS OF Q AGAIN
04810 CAIE A,'INP' ;## INPUT QUEUE?
04820 JRST QDONEB ;## NO
04830 MOVE AR1,INPPAR+Q.FNAM(TT) ;## GET CORRCT FILE NAME
04840 HRRZ A,Q.LEN(TT) ;## GET NUMBER OF FILES SPECIFIED
04850 SOJG A,QDONEC ;## GREATER THAN ONE MEANS THAT USER
04860 ;## SPECIFIED A LOG FILE
04870 PUSHJ P,FILARE ;## WE HAVE TO SET UP LOG FILE
04880 HRRZI A,'LOG' ;## CHANGE EXTENSION TO .LOG
04890 HRLZM A,Q.FEXT(REL)
04900 MOVEM AR1,Q.FNAM(REL) ;## SET TO INP FILE NAME
04910 QDONEC: HRRI A,3
04920 DPB A,[POINT 2,INPPAR+FILPAR+Q.FMOD(TT),2];## SET BITS
04930 ;## INDICATING LOG FILE AND DOESN'T EXIST
04940 ;## (AVOIDS ERROR MSGS FROM QMANGR)
04950 ;## IN SECOND FILE IN CASE USER STUPIDLY SET
04960 ;## UP MORE THAN TWO
04970 QDONEB: SKIPE Q.JOB(TT) ;## SPECIFIED NAME
04980 JRST QDONE1 ;## YES, DONE
04990 MOVEM AR1,Q.JOB(TT)
05000 QDONE1: MOVE C,[EXP 'QMANGR'];## SEGMENT NAME
05010 MOVEI B,400010
05020 MOVE A,TT
05030 PUSHJ P,NEWHI
05040 PUSHJ P,CONCOR ;## CONTRACT CORE
05050 SKIPN CCFLAG ;*** ↑C HIT DURING QUEUE?
05060 JRST FALSE ;## RETURN NIL
05070 POP P,CCFLAG ;*** YES: GO INTERRUPT NOW
05080 JRST CCINT1
05090
05100
05110 ;## ROUTINE TO SWAP HI-SEGMENTS. A CONTAINS ARG TO NEXT HI-SEG, B CONTAINS
05120 ;## LOCATION TO JUMP TO IN NEW HI-SEG. REGS ARE ARG BLOCK TO GETSEG UUO
05130
05140 NEWHI: PUSH P,SP ;## HAVE TO SAVE SP, SINCE MOST
05150 ;## SYSTEM PROGS USE 17 FOR THEIR PDL
05160 MOVEM A,HIARGS# ;## SAVE ARG TO HI-SEG
05170 HRRZM B,HIADDR# ;## SAVE ADDR TO HI-SEG
05180 PUSH P,.JBFF ;%% SAVE OLD VALUE
05190 ;%% (DON'T ASK WHY)
05200 HLRZ B,A ;%% CALCULATE NEW VALUE
05210 ADDI B,1(A) ;%%
05220 MOVEM B,.JBFF ;%% RESET SO QMANGR WON'T WRITE
05230 ;%% OVER ARGUMENT BLOCK.
05240 ;%% JUST BECAUSE LISP IGNORES .JBFF
05250 ;%% DOESN'T MEAN ANYONE ELSE DOES
05260 MOVEM P,PSAVE# ;## SAVE P (CAN'T USE SP)
05270 MOVE SP,P ;## USE RPDL
05280 MOVEI A,CCINTQ ;*** SET NEW ↑C TRAP LOCATION
05290 HRRM A,CCBLK ;***
05300 HRLZI B,'SYS' ;## SYS: IS LOCATION OF NEW HI-SEG
05310 MOVEI A,B ;## B IS STARTING LOCATION OF BLOCK TO GETSEG
05320 SETZB AR1,AR2A ;## CLEAR REST OF BLOCK
05330 SETZB T,TT ;## DITTO
05340 MOVEM SP,SAVSP# ;## SAVE SP AROUND GETSEG (WHICH CLOBBERS ACS)
05350 JRST NEWHI1 ;## GO DO IT
05360
05370 ;## HERE TO GET THAT HI-SEG
05380
05390 REMOTE <
05400 NEWHI1: GETSEG A,
05410 JRST OLDHI ;## FAILED (GIVE UP)
05420 MOVE SP,SAVSP
05430 MOVE A,HIARGS
05440 PUSHJ SP,@HIADDR ;## JUMP TO HI-SEG
05450 OLDHI: MOVEI A,HGHDAT
05460 GETSEG A,
05470 HALT ;## YOU'RE DEAD IF YOU ARE HERE
05480 ENDHI: JRST RESTOR ;## JUMP TO RESTORE THINGS
05490
05500 CCINTQ: SETOM CCFLAG ;*** ↑C HIT: SET FLAG TO CAUSE DELAYED TRAP
05510 SETZM CCBLK+2 ;*** RE-ENABLE ↑C TRAPPING
05520 JRST OLDHI ;*** AND GO GET LISP'S HI-SEG
05530 >
05540
05550
05560 RESTOR: MOVE P,PSAVE
05570 POP P,.JBFF ;%% RESTORE OLD VALUE
05580 POP P,SP
05590 MOVE 0,STNIL
05600 MOVE S,ATMOV
05610 MOVEI A,CCINT ;*** RESTORE ↑C INTERRUPT LOC
05620 HRRM A,CCBLK ;***
05630 POPJ P,
05640
05650
05660 TEMCOR: HRRZ B,CORUSE ;## GET CURRENT CORUSE. THIS ROUTINE EXPANDS CORE
05670 ;## BUT SAVE INFO SO IT CAN BE CONTRACTED LATER
05680 HRL B,.JBREL ;## GET CURRENT CORE EXTENT
05690 MOVEM B,OLDCU ;## SAVE IT (SEE LOADER INTERFACE)
05700 EXPCOR: SETZ D, ;## D IS A RELOC REG
05710 JRST MORCOR ;## EXPAND CORE
05720
05730 CONCOR: MOVS B,OLDCU ;## CONTRACTS CORE, OPPOSITE TEMCOR
05740 HLRZM B,CORUSE
05750 HRRZI B,(B) ;## CLEAR LH
05760 PUSHJ P,MOVDWN ;## MOVE SYMBOL TABLE
05770 CORE B, ;## CONTRACT (B SHOULD BE UNCHANGED
05780 CAI
05790 POPJ P, ;## DONE
05800
05810
05820 QSXARG: MOVEI A,(T)
05830 PUSHJ P,CADAR ;## GET ARGUMENT TO SWITCH
05840 JRST SIXMAK ;## CONVERT IT TO SIXBIT
05850
05860
05870
05880 CLRBLK: SETZM (A) ;## CLEAR FIRST WORD
05890 HLRZ B,A ;## LH OF A CONTAINS LENGTH
05900 ADD B,A
05910 HRL A,A
05920 ADDI A,1 ;## RH NOW CONTAINS SOURCE+1
05930 BLT A,-1(B) ;## BLT CLEARS BLOCK
05940 POPJ P,
05950 ;## PICKUP
05960
05970
05980 CHKGO: CAIN B,(A) ;## SEE IF RH(A)=(B)
05990 HLRZ R,A ;## WHERE TO GO
06000 JRST (R) ;## NO, RETURN
06010 >
06020
06030 PAGE
00010 SUBTTL PRINT
00020
00030 EPRINT: MOVE B,RSTSW ;*** DON'T PRINT IF *RSET = @ERRORX
00040 CAIE B,ERRORX(S) ;***
00050 SKIPN ERRSW ;*** ENTER HERE FOR "SERIOUS" PRINT
00060 POPJ P,
00070 EPRNT1: PUSHJ P,ERRIO
00080 PUSHJ P,PRINT
00090 JRST OUTRET
00100
00110 PRINT: MOVEI R,TYO
00120 PUSHJ P,TERPRI
00130 PUSHJ P,PRIN1
00140 XCT " ",CTY
00150 POPJ P,
00160
00170 PRINC: SKIPA R,.+1
00180 PRIN1: HRRZI R,TYO ;LH(R) .NE. 0 if PRINC
00190 PUSH P,A
00200 PUSHJ P,PRINTA
00210 JRST POPAJ
00220
00230 PRINTA: PUSH P,A
00240 MOVEI B,PRIN3
00250 SKIPGE R
00260 MOVEI B,PRIN4
00270 HRRM B,PRIN5
00280 PUSHJ P,PATOM
00290 JUMPN A,PRINT1
00300 XCT "(",CTY
00310 PRINT3: HLRZ A,@(P)
00320 PUSHJ P,PRINTA
00330 HRRZ A,@(P)
00340 JUMPE A,PRINT2
00350 MOVEM A,(P)
00360 XCT " ",CTY
00370 PUSHJ P,PATOM
00380 JUMPE A,PRINT3
00390 XCT ".",CTY
00400 XCT " ",CTY
00410 PUSHJ P,PRIN1A
00420 PRINT2: XCT ")",CTY
00430 JRST POPAJ
00440
00450 PRINT1: PUSHJ P,PRIN1A
00460 JRST POPAJ
00470 PAGE
00010 PRIN1A: MOVE A,-1(P)
00020 CAILE A,INUMIN
00030 JRST PRINIC
00040 IFE OLDNIL <
00050 CAIN A,NIL ;*** IF NEW NIL THEN
00060 MOVEI A,FAKNIL(S) ;*** GET FAKE ATOM HEADER
00070 >
00080 CAIGE A,@GCP1
00090 CAIGE A,@GCPP1
00100 JRST PRINL
00110 PRIN1B: HRRZ A,(A)
00120 JUMPE A,PRINL
00130 HLRZ B,(A)
00140 HRRZ A,(A)
00150 CAIN B,PNAME(S)
00160 JRST PRINN
00170 CAIN B,FIXNUM(S)
00180 JRST PRINI1
00190 CAIN B,FLONUM(S)
00200 JRSTF @[XWD 0,PRINO] ; TURN OFF DIVIDE CHECK AND UNDERFLOW
00210 IFN BIGNMS<
00220 BPR: JRST PRIN1B ;bignums change here to JRST BPRINT>
00230 JRST PRIN1B
00240
00250 PRINL2: MOVEI R,TYO
00260 JRST PRINL1
00270
00280 PRINL: XCT "#",CTY
00290 HRRZ A,-1(P)
00300 PRINL1: MOVEI C,8
00310 JRST PRINI3
00320
00330 PRINI1: SKIPA A,(A)
00340 PRINIC: SUBI A,INUM0
00350 HRRZ C,VBASE(S)
00360 SUBI C,INUM0
00370 IFE BIGNMS<
00380 JUMPL C,[MOVNS C ;*** NEW -BASE FEATURE
00390 JRST PRINI2]>
00400 JUMPGE A,PRINI2
00410 XCT "-",CTY
00420 MOVNS A
00430 PRINI2: SKIPE %NOPOINT(S) ;*** NEW CODE TO PROVIDE OCTAL POINT
00440 JRST PRINI3
00450 MOVEI B,"."-"0"
00460 CAIN C,TEN
00470 JRST .+4
00480 CAIE C,10
00490 JRST PRINI3
00500 MOVEI B,"Q"-"0"
00510 HRLM B,(P)
00520 PUSH P,PRINI4
00530 PRINI3: LSHC A,-↑D35 ;*** USE DIV FOR 1ST DIVIDE IN CASE
00540 LSH B,-1 ;*** 36 BITS OF SIGNIFICANCE
00550 DIVI A,0(C) ;***
00560 JRST .+2 ;***
00570 IDIVI A,0(C)
00580 HRLM B,(P)
00590 SKIPE A
00600 PUSHJ P,.-3
00610 PRINI4: JRST FP7A1
00620
00630 PRINN: HLRZ A,(A)
00640 MOVEI C,2(SP)
00650 PUSHJ P,PNAMU3
00660 PUSH C,[0]
00670 HRLI C,(POINT 7,0,35)
00680 HRRI C,2(SP)
00690 ILDB A,C
00700 JUMPE A,CPOPJ ;special case of null character
00710 LDB B,RATFLD ;*** SEE IF THIS CHAR STARTS A STRING
00720 CAIN B,STRBEG ;***
00730 JRST PSTR ;string
00740 PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
00750 JUMPL R,PRIN4 ;never slash
00760 JRST PRIN2(B) ;1 for no slash
00770
00780 PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
00790 PRIN2: JRST PRINSL ;*** GO PRINT A SLASH OR ITS EQUIVALENT
00800 PRIN4: PUSHJ P,(R)
00810 ILDB A,C
00820 JUMPN A,@PRIN5#
00830 POPJ P,
00840
00850 PRINSL: MOVE A,SLASHC ;*** GET MOST RECENTLY-USED SLASH CHARACTER
00860 PUSHJ P,(R)
00870 LDB A,C
00880 JRST PRIN4
00890 REMOTE<
00900 SLASHC: "/">
00910
00920 PSTR: LDB B,[POINT 7,(C),13] ;*** GET THE SECOND CHARACTER OF THE PNAME
00930 JUMPE B,PRIN2X ;*** IF NOT THERE THIS IS /", NOT A STRING
00940 PSTR3: SKIPL R ;dont print " if no slashify
00950 PSTR2: PUSHJ P,(R)
00960 ILDB A,C
00970 LDB B,STRFLD ;*** SEE IF THIS CHAR ENDS A STRING
00980 CAIE B,STREND ;***
00990 JUMPN A,PSTR2
01000 JUMPN A,PSTR3
01010 POPJ P,
01020
01030 TERPRI: PUSH P,A
01040 MOVEI A,CR
01050 PUSHJ P,TYO
01060 MOVEI A,LF
01070 PUSHJ P,TYO
01080 JRST POPAJ
01090
01100 CTY: JSA A,TYOI
01110 REMOTE<
01120 TYOI: X
01130 JRST TYOI2>
01140 TYOI2: PUSH P,A
01150 LDB A,[POINT 6,-1(A),ACFLD]
01160 PUSHJ P,(R)
01170 POP P,A
01180 JRA A,(A)
01190
01200 PRINO: MOVE A,(A)
01210 CLEARB B,C
01220 JUMPG A,FP1
01230 JUMPE A,FP3
01240 MOVNS A
01250 XCT "-",CTY
01260 FP1: CAMGE A,FT01
01270 JRST FP4
01280 CAML A,FT8
01290 AOJA B,FP4
01300
01310 FP3: MULI A,400
01320 ASHC B,-243(A)
01330 MOVE A,B
01340 CLEARM FPTEM#
01350 PUSHJ P,FP7
01360 XCT ".",CTY
01370 MOVNI T,8
01380 ADD T,FPTEM
01390 MOVE B,C
01400
01410 FP3A: MOVE A,B
01420 MULI A,TEN
01430 PUSHJ P,FP7B
01440 SKIPE B
01450 AOJL T,FP3A
01460 POPJ P,
01470
01480 FP4: MOVNI C,6
01490 MOVEI TT,0
01500 FP4A: ADDI TT,1(TT)
01510 XCT FCP(B)
01520 TRZA TT,1
01530 FMPR A,@FCP+1(B)
01540 AOJN C,FP4A
01550 PUSH P,TT
01560 MOVNI B,-2(B)
01570 DPB B,[POINT 2,FP4C,34]
01580 PUSHJ P,FP3
01590 MOVEI A,"E"
01600 PUSHJ P,(R)
01610 MOVE A,FP4C#
01620 IORI A,51
01630 PUSHJ P,(R)
01640 POP P,A
01650 FP7: JUMPE A,FP7A1
01660 IDIVI A,TEN
01670 AOS FPTEM
01680 HRLM B,(P)
01690 JUMPE A,FP7A1
01700 PUSHJ P,FP7
01710
01720 FP7A1: HLRE A,(P)
01730 FP7B: ADDI A,"0"
01740 JRST (R)
01750
01760 353473426555 ;1e32
01770 266434157116 ;1e16
01780 FT8: 1.0E8
01790 1.0E4
01800 1.0E2
01810 1.0E1
01820 FT: 1.0E0
01830 026637304365 ;1e-32
01840 113715126246 ;1e-16
01850 146527461671 ;1e-8
01860 163643334273 ;1e-4
01870 172507534122 ;1e-2
01880 FT01: 175631463146 ;1e-1
01890 FT0:
01900 FCP: CAMLE A,FT0(C)
01910 CAMGE A,FT(C)
01920 XWD C,FT0
01930
01940 PAGE
00010 SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69
00020
00030 ;magic scanner table bit definitions
00040
00050 ;bit 0=0 iff slashified as nth id character
00060 ;bit 1=0 iff slashified as 1st id character
00070 ;bits 2-5 ratab index (scanning for atom)
00080 ;bits 6-8 dotab (and numfld) index (after dot or in number)
00090 ;bits 9-10 strtab index (in string)
00100 ;bits 11-13 idtab index (in atomic symbol)
00110 ;bits 14-16 exptab index (in exponent)
00120 ;bits 17-19 rdtab index (type of delimiter)
00130 ;bits 20-25 ascii to radix 50 conversion
00140
00150 REMOTE<
00160 IGSTRT: IGCRLF
00170 IGEND: LF
00180
00190 RATFLD: POINT 4,CHRTAB(A),5
00200 STRFLD: POINT 2,CHRTAB(A),10
00210 IDFLD: POINT 3,CHRTAB(A),13
00220 >
00230 DOTFLD:
00240 NUMFLD: POINT 3,CHRTAB(A),8
00250 EXPFLD: POINT 3,CHRTAB(A),16
00260 RDFLD: POINT 3,CHRTAB(A),19
00270 R50FLD: POINT 6,CHRTAB(A),25
00280
00290 ;magic state flags in t
00300 EXP==1 ;exponent
00310 NEXP==2 ;negative exponent
00320 SAWDOT==4 ;saw a dot (.)
00330 MINSGN==10 ;negative number
00340 SAWQ==20 ;*** SAW A Q (OCTAL POINT)
00350
00360 IDCLS==0 ;identifier
00370 STRCLS==1 ;string
00380 NUMCLS==2 ;number
00390 DELCLS==3 ;delimiter
00400
00410 PAGE
00010 ;macros for scanner table
00020
00030 DEFINE RAD50 (X)<
00040 IFB <X>,<R50VAL=0>
00050 IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
00060 IFIDN <"X"><".">,<R50VAL=45>
00070 IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
00080
00090 DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
00100 XLIST
00110 IRPC R50< RAD50 (R50)
00120 BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
00130 LIST>
00140
00150 DEFINE LET (X)<
00160 TABIN (1,1,5,2,3,4,2,0,X)>
00170
00180 DEFINE DELIMIT (X,Y)<
00190 TABIN (0,0,2,2,3,2,2,Y,X)>
00200
00210 DEFINE IGNORE (X)<
00220 TABIN (0,0,3,2,3,2,2,0,X)>
00230 PAGE
00010 REMOTE<CHRTAB:
00020 TABIN (0,0,1,1,1,1,1,0,< >)
00030 ;null
00040 LET (< >)
00050 IGNORE (< >)
00060 ;tab,lf,vtab,ff,cr
00070 LET (< >)
00080 ;16 to 30
00090 TABIN (0,0,0,0,0,0,0,0,< >)
00100 ;igmrk
00110 TABIN (0,0,0,0,0,0,0,0,< >)
00120 ;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
00130 IFE ALTMOD-33 <
00140 DELIMIT (< >,3)
00150 > ;%% NEW ALTMODE (5S06 MONITOR)
00160 IFN ALTMOD-33 <
00170 LET (< >)
00180 > ;%% OLD ALTMODE (5S04 OR EARLIER MONITOR)
00190 LET (< >)
00200 ;## 34 TO 37
00210 IGNORE (< >)
00220 ;space
00230 LET (< >)
00240 ;!
00250 TABIN (0,0,9,2,2,2,2,0,< >)
00260 ;"
00270 LET (< $% >)
00280 ;#$%&'
00290 DELIMIT (< >,0)
00300 DELIMIT (< >,1)
00310 ;()
00320 LET (< >)
00330 ;*
00340 TABIN (1,1,14,2,3,4,2,0,< >)
00350 ;+
00360 IGNORE (< >)
00370 ;,
00380 TABIN (1,1,6,2,3,4,2,0,< >)
00390 ;-
00400 TABIN (0,0,7,3,3,2,2,4,<.>)
00410 TABIN (0,0,4,2,3,3,2,0,< >)
00420 ;/
00430 TABIN (1,0,8,5,3,4,3,0,<0123456789>)
00440 LET (< >)
00450 ;:;<=>?
00460 TABIN (1,0,2,2,3,4,2,5,< >)
00470 ;@
00480 LET (<ABCD>)
00490 TABIN (1,1,5,4,3,4,2,0,<E>)
00500 LET (<FGHIJKLMNOP>)
00510 ;*** SPECIAL ENTRY FOR Q = OCTAL POINT
00520 TABIN (1,1,5,6,3,4,2,0,<Q>)
00530 LET (<RSTUVWXYZ>)
00540 DELIMIT (< >,2)
00550 ;[
00560 LET (< >)
00570 ;\
00580 DELIMIT (< >,3)
00590 ;]
00600 LET (< >)
00610 ;↑←`
00620 LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
00630 ;lower case
00640 LET (< >)
00650 ;{|
00660 IFE ALTMOD-175 <
00670 DELIMIT (< >,3)
00680 > ;%% OLD ALTMODE (5S04 MONITOR)
00690 IFN ALTMOD-175 <
00700 LET (< >)
00710 > ;%% ⎇ - ORDINARY CHARACTER (5S06 MONITOR)
00720 LET (< >)
00730 ;}
00740 DELIMIT (< >,6)
00750 ;rubout
00760 >
00770 PAGE
00010 READCH: PUSHJ P,TYI
00020 MOVSI AR1,AR1
00030 PUSHJ P,EXPL1
00040 JRST CAR
00050
00060 READP1: SETZM NOINFG
00070 READ0: PUSH P,TYI2
00080 PUSH P,OLDCH
00090 SETZM OLDCH#
00100 HRLI A,(JRST)
00110 MOVEM A,TYI2
00120 PUSHJ P,READ+1
00130 POP P,OLDCH
00140 POP P,TYI2
00150 POPJ P,
00160
00170 RDNAM: SETOM NOINFG ;## READ ROUTINE THAT DOES NOT INTERN
00180 JRST READ+1 ;##
00190
00200 RDRUB: MOVEI A,CR
00210 PUSHJ P,TTYO
00220 MOVEI A,LF
00230 PUSHJ P,TTYO
00240 SKIPA P,PSAV#
00250 READ: SETZM NOINFG# ;0 means intern
00260 SETZM EDFLAG ;*** CLEAR AUTO EDIT FLAG
00270 SETOM TLKFLG ;*** SET TO DO A TALK IF TTY READ
00280 MOVEM P,PSAV
00290 PUSHJ P,READ1
00300 SETZM PSAV
00310 SETZM INREAD ;WMT-CLEAR INDICATOR THAT YOU'RE IN READ
00320 SKIPN EDFLAG ;*** AUTO EDIT KEY STRUCK?
00330 POPJ P,
00340 PUSHJ P,QTIFY ;*** YES: CONSTRUCT (EDITEXPR @exp)
00350 PUSHJ P,NCONS
00360 MOVEI B,EDITEXPR(S)
00370 PUSHJ P,XCONS
00380 JRST EVAL ;*** AND GO EDIT EXPR BEFORE RETURNING IT
00390
00400 READ1: PUSHJ P,RATOM
00410 POPJ P, ;atom
00420 XCT RDTAB2(B)
00430 JRST READ1 ;try again
00440
00450 RDTAB2: JRST READ2 ;0 (
00460 JFCL ;1 )
00470 JRST READ4 ;2 [
00480 JFCL ;3 ],$
00490 JFCL ;4 .
00500 JRST RDQT ;5 @
00510
00520 READ2: SETOM INREAD ;WMT-NOTE THAT YOU'RE IN READ
00530 PUSHJ P,RATOM
00540 JRST READ2A ;atom
00550 XCT RDTAB(B)
00560
00570 READ2A: PUSH P,A
00580 PUSHJ P,READ2
00590 JRST POPBXC
00600
00610 RDTAB: PUSHJ P,READ2 ;0 (
00620 JRST FALSE ;1 )
00630 PUSHJ P,READ4 ;2 [
00640 JRST READ5 ;3 ],$
00650 JRST RDT ;4 .
00660 PUSHJ P,RDQT ;5 @
00670
00680 RDTX: PUSHJ P,RATOM
00690 POPJ P, ;atom
00700 XCT RDTAB2(B)
00710 JRST DOTERR ;dot context error
00720
00730 RDT: PUSHJ P,RDTX
00740 PUSH P,A
00750 PUSHJ P,RATOM
00760 JRST DOTERR
00770 CAIN B,1
00780 JRST POPAJ
00790 CAIE B,3
00800 JRST DOTERR
00810 MOVEM A,OLDCH
00820 JRST POPAJ
00830
00840
00850 READ4: PUSHJ P,READ2
00860 MOVE B,OLDCH
00870 CAIE B,ALTMOD
00880 TYI1: SETZM OLDCH ;kill the ]
00890 POPJ P,
00900
00910 READ5: MOVEM A,OLDCH ;save ] or $
00920 JRST FALSE ;and return nil
00930
00940
00950 RDQT: PUSHJ P,READ1
00960 JRST QTIFY
00970 PAGE
00010 ;atom parser
00020
00030 COMMENT: PUSHJ P,TYID
00040 CAME A,IGEND
00050 JRST COMMENT
00060 POPJ P,
00070
00080 RATOM: SKIPE SMAC# ;$$ CHECK FOR A SPLICE MACRO LIST
00090 JRST PSMAC ;$$ GET ITEM FROM SPLICE MACRO LIST
00100 SETZB T,R
00110 HRLI C,(POINT 7,0,35)
00120 HRRI C,(SP)
00130 MOVEM C,ORGSTK# ;SAVE FOR BACKING UP ON + AND -
00140 MOVEI AR1,1
00150 RATOM2: PUSHJ P,TYIA
00160 LDB B,RATFLD
00170 JRST RATAB(B)
00180
00190 SLCHAR==4 ;*** SLASH ENTRY FOR MODCHR
00200 STRBEG==↑D9 ;*** STRING START FOR PRINT
00210 RATAB: PUSHJ P,COMMENT ;0 comment
00220 JRST RATOM2 ;1 null
00230 JRST RATOM3 ;2 delimit
00240 JRST RATOM2 ;3 ignore
00250 PUSHJ P,TYI ;4 /
00260 JRST RDID ;5 letter
00270 JRST RDNMIN ;6 -
00280 JRST RDOT ;7 .
00290 JRST RDNUM ;8 digit
00300 JRST RDSTR0 ;9 string
00310 JRST RMACRO ;10 MACRO
00320 JRST SMACRO ;11 SPLICE MACRO
00330 JRST RDNPLS ;12 +
00340
00350 ;a real dotted pair
00360 RDOT2: MOVEM A,OLDCH
00370 MOVE A,ORGSGN ;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
00380 RATOM3: LDB B,RDFLD
00390 HRRI R,DELCLS ;delimiter
00400 AOS (P) ;non-atom (ie a delimiter)
00410 POPJ P,
00420
00430 ;dot handler
00440 RDOT: MOVEM A,ORGSGN ;INCASE SOMETHING ELSE DEFINED AS "."
00450 PUSHJ P,TYID
00460 LDB B,DOTFLD
00470 JRST DOTAB(B)
00480
00490 DOTAB: PUSHJ P,COMMENT ;0 comment
00500 JRST RDOT+1 ;1 null
00510 JRST RDOT2 ;2 delimit
00520 JRST RDOT2 ;3 dot
00530 JRST RDOT2 ;4 e
00540 JRST .+2 ;5 digit
00550 JRST RDOT2 ;6 Q (***)
00560 MOVEI B,0
00570 IDPB B,C
00580 TLO T,SAWDOT
00590 JRST RDNUM
00600 PAGE
00010 ;string scanner
00020 STREND==2 ;*** STRING DELIMITER FOR PRINT
00030 RDSTR0: PUSH P,%TTYUC(S) ;WMT-SAVE %TTYUC
00040 SETZM %TTYUC(S) ;WMT-CLEAR TO ZERO
00050 JRST RDSTR ;WMT
00060 STRTAB: PUSHJ P,COMMENT ;0 comment
00070 JRST RDSTR+1 ;1 null
00080 JRST STR2 ;2 delimit
00090 RDSTR: IDPB A,C ;3 string element
00100 PUSHJ P,TYID
00110 LDB B,STRFLD
00120 JRST STRTAB(B)
00130
00140 STR2: POP P,%TTYUC(S) ;WMT-RESTORE %TTYUC
00150 HRRI R,STRCLS ;string
00160 IDPB A,C
00170 SKIPE INTSTR(S) ;*** ARE WE INTERNING STRINGS?
00180 JRST MAKID+1 ;*** YES
00190 NOINTR: PUSHJ P,IDEND ;no intern
00200 PUSHJ P,IDSUB
00210 JRST PNAMAK
00220
00230
00240 ;identifier scanner
00250 IDTAB: PUSHJ P,COMMENT ;0
00260 JRST RDID+1 ;1 null
00270 JRST MAKID ;2 delimit
00280 PUSHJ P,TYI ;3 /
00290 RDID: IDPB A,C ;4 letter or digit
00300 PUSHJ P,TYID
00310 LDB B,IDFLD
00320 JRST IDTAB(B)
00330 PAGE
00010 ;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
00020 ;
00030 LINRD: JUMPE T,LINRD1 ;WMT- DO INITIAL READ IF NO ARGS
00040 MOVE A,0(P) ;WMT- GET FIRST ARG
00050 MOVNS T
00060 HRLI T,(T)
00070 SUB P,T ;WMT- MAKE STACK RIGHT
00080 JUMPE A,LINRD1 ;WMT- DO INITIAL READ IF ARG=NIL
00090 CLRBFI ;WMT- CLEAR FROM PREVIOUS INPUT
00100 SETZB B,SMAC ;WMT- CLEAR SPLICE INPUT
00110 JRST LRTY ;WMT- GO INPUT A CHARACTER
00120 LINRD1: PUSHJ P,READ
00130 HRRZ B,A
00140 SKIPE SMAC ;CHECK THE SPLICE LIST
00150 JRST LRMORE
00160 SKIPN A,OLDCH
00170 LRTY: PUSHJ P,TYID ;NEED A CHARACTER
00180 MOVEM A,OLDCH ;SAVE IT
00190 LDB C,RATFLD ;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
00200 CAIN C,7 ;SPECIAL CHECK FOR "."
00210 JRST LRTY1 ;IGNORE IT
00220 CAILE C,3 ;ELIMINATE MOST POSSIBILITIES
00230 JRST LRMORE ;MORE ON THE LINE
00240 JUMPE C,LREND ;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
00250 LDB C,RDFLD
00260 JRST LR1(C)
00270 LR1: JRST LPIG ;0 MORE TO FIGURE OUT
00280 JRST LRTY1 ;1 IGNORE
00290 JRST LRMORE ;2 MORE ON THE LINE
00300 SUBI A,ALTMOD ;3 CHECK ALTMOD
00310 JUMPN A,LRTY1 ;4 IGNORE "]" AND "."
00320 JUMPN A,LRMORE ;5 MORE ON "@"
00330 JRST LREND
00340 LPIG: CAIN A,"(" ;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
00350 JRST LRMORE
00360 CAIE A,TAB
00370 CAIL A,40 ;READ MORE IF SPACE, COMMA, OR TAB
00380 JRST [ HRLI B,-1 ;SET SPQCE FLAG AND TRY AGAIN
00390 JRST LRTY]
00400 CAIE A,CR ;ALWAYS IGNORE CR.S
00410 TLZE B,-1 ;EOL - IF SPACE FLAG THEN DO A PEEKC
00420 JRST LRTY
00430 LREND: HRRZ A,B ;FINALLY GOT THERE
00440 ; SETZM OLDCH ;WMT- EAT THE BREAK CHARACTER
00450 ;WMT- I DON'T KNOW WHY I HAD THAT INSTRUCTION THERE.
00460 JRST NCONS
00470 LRMORE: HRLI B,0
00480 PUSH P,B ;MORE TO GO, PUSH
00490 PUSHJ P,LINRD1 ;AND CALL YOURSELF
00500 JRST POPBXC
00510 LRTY1: HRLI B,0 ;CLEAR SPACE FLAG
00520 JRST LRTY
00530
00540 PAGE
00010 ;## FUNCTIONS TO READ A FILE.EXT
00020 ;## READ A FILE.EXT FROM THE UFD
00030
00040 FLTYIA: XCT TYI2 ;## GET NEXT WORD, IGNORE OLDCH
00050 JRST [SETZ AR1,
00060 JRST TYI2X ] ;%% INPUT SOME MORE, CLEARING TEST REG.
00070 ILDB A,@TYI3 ;## AND LOAD WORD
00080 POPJ P,
00090
00100
00110 RDFIL1: PUSHJ P,FLTYIA ;## FILE NAME NOT THERE, SKIP OVER EXT
00120 RDFILE: SETZM NOINFG ;## ## INTERN
00130 PUSHJ P,FLTYIA ;## GET FILE NAME WORD
00140 PUSHJ P,SIXATM ;## MAKE IT AN ATOM
00150 JUMPL A,RDFIL1 ;## A=-1 IF EMPTY
00160 PUSH P,A
00170 PUSHJ P,FLTYIA ;## GET EXTENSION
00180 HRRI A,0 ;## CLEAR RH
00190 PUSHJ P,SIXATM
00200 JUMPL A,POPAJ ;## NO EXTENSION, RETURN
00210 POPBXC: POP P,B ;## GET FILE BACK
00220 JRST XCONS ;## RETURN FILE.EXT
00230
00240 SIXCAT: ;WMT-MAKES A DEVICE NAME FROM LEFT JUSTIFIED SIXBIT
00250 MOVE B,[POINT 6,A] ;WMT-GO THROUGH EACH CHAR
00260 ILDB C,B
00270 JUMPN C,.-1 ;WMT- UNTIL YOU GET TO END
00280 MOVEI C,':' ;WMT-LOAD A COLON
00290 DPB C,B ;WMT- INTO NEXT POSITION
00300 ; JRST SIXATM ;WMT- AND MAKE ATOM
00310 ; FALLS THROUGH
00320
00330 ;## ROUTINE TO TAKE ONE WORD OF SIXBIT AND MAKE IT AN ATOM
00340 ;## IGNORES TRAILING BLANKS, BUT INCLUDES INSERTED BLANKS. NO
00350 ;## READ MACROS, ETC.
00360
00370 SIXATM: SKIPN B,A
00380 JRST SXATER ;## INDICATE WORD EMPTY
00390 MOVEI T,5 ;## OF CHS PERMISSIBLE IN FULL WORD
00400 ;## NAME T=0 IF FIRST WORD DONE
00410 MOVE AR1,[POINT 6,B,5] ;## AR1 HAS PTR TO LOAD BYTE
00420 ;## FROM B TO C
00430 PUSHJ P,SIXAT1 ;## MAKE THE PNAME LIST
00440 PUSHJ P,NCONS
00450 MOVEI B,PNAME(S) ;## MAKE PNAME
00460 PUSHJ P,XCONS
00470 PUSHJ P,ACONS ;## VOILA, AN ATOM
00480 SKIPE NOINFG ;## NOINFG=0 MEANS INTERN
00490 POPJ P,
00500 JRST INTERN
00510
00520 SXATER: SETO A, ;## RETURN -1 IN A IF B EMPTY
00530 POPJ P,
00540 SIXAT1: MOVE AR2A,[POINT 7,0,35] ;## POINTER TO MOVE C TO A
00550 SETZ A, ;## CLEAR A
00560 SIXAT2: SETZ C,
00570 JUMPE B,SIXDON ;## DONE IF B EMPTY
00580 LDB C,AR1
00590 LSH B,6 ;## LEFT SHIFT B, REMAINING CH'S IN B
00600 HRRI C,40(C) ;## ADD 40 TO C
00610 IDPB C,AR2A ;## PUT IT IN A
00620 SOJG T,SIXAT2 ;## IF T>0, STILL IN FIRST WORD OF PNAME
00630 SIXAT3: PUSHJ P,FWCONS
00640 PUSH P,A
00650 JRST SIXAT1 ;## TRY FOR THAT SIXTH CH.
00660 SIXDON: JUMPN A,SIXAT3 ;## IF A NOT EMPTY, DO ANOTHER FWCONS AND
00670 ;## END UP HERE WITH A=0.
00680 POP P,A
00690 PUSHJ P,NCONS
00700 JUMPGE T,CPOPJ ;## IF T>=0, THEN ONLY ONE WORD
00710 JRST POPBXC ;## DONE
00720 PAGE
00010 ;NEW AND SUPER BITCHEN READ MACROS
00020 ;
00030 RMACRO:
00040 IFN ALVINE,<
00050 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
00060 JRST RATOM2 ;$$ YES, IGNORE>
00070 RMAC2: IDPB A,C ;$$ CONVERT THE CHAR. TO AN ATOM
00080 PUSHJ P,IDEND ;$$
00090 PUSHJ P,INTER0 ;$$
00100 MOVEM A,T ;$$ SAVE ATOM IN CASE OF ERROR
00110 MOVEI B,READMACRO(S) ;$$ GET THE FUNCTION NAME
00120 PUSHJ P,GET ;$$
00130 JUMPE A,RMERR ;$$ UNDEFINED READ MACRO
00140 PUSHJ P,NCONS ;$$ CONVERT TO A FORM
00150 PUSH P,PSAV ;$$
00160 PUSHJ P,EVAL ;$$ EVALUATE THE FORM
00170 POP P,PSAV ;$$
00180 POPJ P, ;$$ RETURN
00190
00200 ;SPECIAL PROCESSING OF SPLICE MACROS
00210 SMACRO:
00220 IFN ALVINE,<
00230 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
00240 JRST RATOM2 ;$$ YES, IGNORE>
00250 PUSHJ P,RMAC2 ;$$ EVALUATE THE MACRO
00260 MOVEM A,SMAC ;$$ SAVE THE SPLICE LIST
00270 JRST RATOM ;$$ START OVER
00280
00290 ;GET AN ITEM OFF OF THE SPLICE LIST
00300 PSMAC: MOVE A,SMAC ;$$
00310 PUSHJ P,ATOM ;$$ IS SPLICE LIST AN ATOM?
00320 JUMPN A,[ MOVE A,SMAC ;$$ YES, SIMULATE . <ATOM>
00330 PUSHJ P,NCONS ;$$
00340 MOVEM A,SMAC ;$$
00350 MOVEI B,4 ;$$
00360 JRST RATOM3+1] ;$$
00370 MOVE B,@SMAC ;$$
00380 HLRZ A,B ;$$ RETURN NEXT ITEM OF SPLICE LIST
00390 HRRZM B,SMAC ;$$ ADVANCE SPLICE LIST
00400 POPJ P, ;$$ RETURN
00410 PAGE
00010 ;number scanner
00020 NUMTAB: PUSHJ P,COMMENT ;0 comment
00030 JRST RDNUM+1 ;1 null
00040 JRST NUMAK ;2 delimit
00050 JRST RDNDOT ;3 dot
00060 JRST RDE ;4 e
00070 JRST RDNUM ;5 digit
00080 JRST RDQ ;6 Q (***)
00090 RDNUM: IDPB A,C
00100 PUSHJ P,TYID
00110 LDB B,NUMFLD
00120 JRST NUMTAB(B)
00130
00140 RDNDOT: TLOE T,SAWDOT
00150 JRST NUMAK ;two dots - delimit
00160 MOVEI A,0
00170 JRST RDNUM
00180
00190 RDQ: TLNE T,SAWDOT ;*** SAW A Q - IS IT OCTAL POINT?
00200 JRST NUMAK ;*** NO - DELIMITER
00210 TLO T,SAWQ ;*** YES
00220 PUSHJ P,TYID ;*** GO GET DELIMITER
00230 JRST NUMAK ;*** AND MAKE NUMBER
00240
00250 RDNMIN: TLO T,MINSGN
00260 RDNPLS: MOVEM A,ORGSGN# ;SAVE SIGN IN CASE OF BACKUP
00270 JRST RDNUM+1
00280
00290 ;exponent scanner
00300 RDE: CAME C,ORGSTK ;FOR +E AND -E TYPE OF ATOMS
00310 JRST .+3
00320 MOVEM A,OLDCH
00330 JRST KLDG1
00340 TLO T,EXP
00350 MOVEI A,0
00360 IDPB A,C
00370 PUSHJ P,TYID
00380 CAIN A,"-"
00390 TLOA T,NEXP
00400 CAIN A,"+"
00410 JRST RDE2+1
00420 JRST RDE2+2
00430
00440 EXPTAB: PUSHJ P,COMMENT ;0
00450 JRST RDE2+1 ;1 null
00460 JRST NUMAK ;2 delimit
00470 RDE2: IDPB A,C ;3 digit
00480 PUSHJ P,TYID
00490 LDB B,EXPFLD
00500 JRST EXPTAB(B)
00510 PAGE
00010 ;semantic routines
00020 ;identifier interner and builder
00030
00040 IDEND: TDZA A,A
00050 IDEND1: IDPB A,C
00060 TLNE C,760000
00070 JRST IDEND1
00080 POPJ P,
00090
00100 MAKID: MOVEM A,OLDCH
00110 SKIPE NOINFG
00120 JRST NOINTR ;dont intern it
00130 PUSHJ P,IDEND ;*** (MOVED FROM JUST AFTER MAKID)
00140 INTER0: PUSHJ P,IDSUB
00150 PUSHJ P,INTER1 ;is it in oblist
00160 POPJ P, ;found
00170 PUSHJ P,PNAMAK ;not there
00180 MAKID2: MOVE C,CURBUC# ;
00190 HLRZ B,@RHX2
00200 PUSHJ P,CONS ;cons it into the oblist
00210 HRLM A,@RHX2
00220 JRST CAR
00230
00240 ;pname unmaker
00250 PNAMUK:
00260 MOVEI B,PNAME(S)
00270 PUSHJ P,GET
00280 JUMPE A,NOPNAM
00290 MOVE C,SP
00300 PNAMU3: HLRZ B,(A)
00310 PUSH C,(B)
00320 HRRZ A,(A)
00330 JUMPN A,PNAMU3
00340 POPJ P,
00350
00360 ;idsub constructs a iowd pointer for a print name
00370 IDSUB: HRRZS C
00380 CAML C,JRELO ;top of spec pdl
00390 JRST SPDLOV
00400 MOVNS C
00410 ADDI C,(SP)
00420 HRLI C,1(SP)
00430 MOVSM C,IDPTR#
00440 POPJ P,
00450
00460 PAGE
00010 ;identifier interner
00020 INTER1: MOVE B,1(SP) ;get first word of pname
00030 LSH B,-1 ;right justify it
00040 IDIV B,INT1 ;compute hash code
00050 REMOTE<
00060 INT1: BCKETS
00070 RHX2:
00080 XXX1: XWD B+1,OBTBL>
00090 PUSH P,C ;## SAVE C
00100 HRRZ C,VOBLIST(S) ;## THIS GETS THE CURRENT VALUE OF OBLIST(THE ATOM)
00110 HRRM C,RHX2 ;## ASSUMES THAT ALL REFERENCE TO OBLIST GOES
00120 HRRM C,RHX5 ;## IE INTERN, REMOB ETC GOES THROUGH THIS SECTION.
00130 POP P,C ;##RHX2 AND RHX5 ARE HOPEFULLY THE ONLY TWO WORDS
00140 ;##WHICH ARE USED TO REFERENCE TABLE 3/28/73
00150 HLRZ TT,@RHX2 ;get bucket
00160 MOVEM B+1,CURBUC ;save bucket number
00170 MOVE T,TT
00180 JRST MAKID1
00190
00200 MAKID3: MOVE TT,T ;save previous atom
00210 HRRZ T,(T) ;get next atom
00220 MAKID1: JUMPE T,CPOPJ1 ;not in oblist
00230 HLRZ A,(T) ;next id in oblist
00240 PUSHJ P,CMPNAM ;*** GO COMPARE PNAMES
00250 JRST MAKID3 ;*** NOT THE SAME - TRY NEXT
00260 HLRZ A,(T) ;this is it
00270 HLRZ B,(TT)
00280 HRLM A,(TT) ;(*** BUBBLE TOWARDS FRONT)
00290 HRLM B,(T)
00300 POPJ P,
00310
00320 ;*** PNAME COMPARER
00330 CMPNAM: MOVEI B,PNAME(S) ;## USE GET FOR GETTING PNAME
00340 PUSHJ P,GET ;## (GET ATOM @PNAME)
00350 JUMPE A,NOPNAM ;## NO PRINT NAME
00360 MOVE C,IDPTR ;found pname
00370 CMPNM1: JUMPE A,CPOPJ ;not the one
00380 MOVS A,(A)
00390 MOVE B,(A)
00400 ANDCAM AR1,(C) ;clear low bit
00410 CAME B,(C)
00420 JRST CPOPJ ;not the one
00430 HLRZ A,A ;ok so far
00440 AOBJN C,CMPNM1
00450 JUMPE A,CPOPJ1 ;PNAMEs match
00460 POPJ P, ;not the one
00470
00480 PAGE
00010 ;pname builder
00020 PNAMAK: MOVE T,IDPTR
00030 PUSHJ P,NCONS
00040 MOVE TT,A
00050 MOVE C,A
00060 PNAMB: MOVE A,(T)
00070 TRZ A,1 ;clear low bit!!!!!
00080 PUSHJ P,FWCONS
00090 PUSHJ P,NCONS
00100 HRRM A,(TT)
00110 MOVE TT,A
00120 AOBJN T,PNAMB
00130 MOVE A,C
00140 HRLZS (A)
00150 JRST PNGNK1+1
00160 PAGE
00010 ;number builder
00020 NUMAK: MOVEM A,OLDCH
00030 HRRI R,NUMCLS ;number
00040 CAME C,ORGSTK ;BIG KLUDGE FOR + AND -
00050 JRST .+5
00060 KLDG1: MOVE A,ORGSGN ;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
00070 IDPB A,C
00080 PUSHJ P,TYIA
00090 JRST RDID+2
00100 MOVEI A,0
00110 IDPB A,C
00120 IDPB A,C
00130 HRRZS C
00140 CAML C,JRELO ;top of spec pdl
00150 JRST SPDLOV
00160 MOVSI C,(POINT 7,0,35)
00170 HRRI C,(SP)
00180 TLNE T,SAWDOT+EXP
00190 JRST NUMAK2 ;decimal number or flt pt
00200 MOVE A,VIBASE(S) ;ibase integer
00210 SUBI A,INUM0
00220 TLNE T,SAWQ ;*** CHECK IF OCTAL POINT SEEN
00230 MOVEI A,10 ;*** YES: BASE = 8
00240 PUSHJ P,NUM
00250 NUMAK4:
00260 MOVEI B,FIXNUM(S)
00270 NUMAK6: TLNE T,MINSGN
00280 MOVNS A
00290 JRST MAKNUM
00300
00310 NUMAK2: PUSHJ P,NUM10
00320 MOVEM A,TT
00330 TLNN T,SAWDOT
00340 JRST [ PUSHJ P,FLOAT ;flt pt without fraction
00350 MOVE TT,A
00360 JRST NUMAK3]
00370 SETZ AR2A, ;*** CLEAR NUMBER COUNTER
00380 PUSHJ P,NUM10 ;fraction part
00390 EXCH A,TT
00400 TLNN T,EXP
00410 JUMPE AR2A,NUMAK4 ;no exponent and no fraction
00420 PUSHJ P,FLOAT
00430 EXCH A,TT
00440 PUSHJ P,FLOAT
00450 MOVEI AR1,FT01
00460 PUSHJ P,FLOSUB
00470 FMPR A,B
00480 FADRM A,TT
00490 NUMAK3: PUSHJ P,NUM10 ;exponent part
00500 IFE BIGNMS<
00510 JFCL 10,.+1 ;*** CLEAR THE FLAG>
00520 MOVE AR2A,A
00530 MOVEI AR1,FT-1
00540 TLNE T,NEXP
00550 MOVEI AR1,FT01 ;-exponent
00560 PUSHJ P,FLOSUB
00570 FMPR TT,B ;positive exponent
00580 MOVEI B,FLONUM(S)
00590 MOVE A,TT
00600 JFCL 10,FLOOV
00610 JRST NUMAK6
00620
00630 FLOSUB: MOVSI B,(1.0)
00640 TRZE AR2A,1
00650 FMPR B,(AR1)
00660 JUMPE AR2A,CPOPJ
00670 LSH AR2A,-1
00680 SOJA AR1,FLOSUB+1
00690
00700 ;variable radix integer builder
00710 ;*** CHANGED TO HANDLE 36-BIT INTEGERS (UNLESS BIGNMS SWITCH ON)
00720 ;*** ANYTHING OVER 36-BITS IS NOW IGNORED INSTEAD OF CAUSING ERROR
00730
00740 NUM10: MOVEI A,TEN
00750 NUM: HRRM A,NUM1
00760 IFN BIGNMS< JFCL 10,.+1> ;CLEAR FLAG IF CONCERNED ABOUT OVERFLOW
00770 SETZB A,B ;A=NUMBER, B=OVERFLOW
00780 NUM2: ILDB D,C
00790 JUMPE D,NUM4
00800 IFN BIGNMS< IMUL A,NUM1#> ;IMUL TO CHECK FOR OVERFLOW
00810 IFE BIGNMS<
00820 MUL A,NUM1# ;MUL FOR 36 BITS
00830 EXCH A,B>
00840 ADDI A,-"0"(D)
00850 IFN BIGNMS<
00860 NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm>
00870 IFE BIGNMS<
00880 TLZE A,400000 ;ADD THE 36TH BIT TO OVERFLOW REG.
00890 ;WMT- IS THIS NEXT INSTRUCTION RIGHT??????
00900 AOJ B>
00910 AOJA AR2A,NUM2
00920 NUM4:
00930 IFE BIGNMS<
00940 LSH A,1 ;MOVE HI-ORDER BIT INTO RESULT
00950 ROTC A,-1>
00960 POPJ P,
00970 PAGE
00010 INTERN: MOVEM A,AR2A
00020 PUSHJ P,PNAMUK
00030 PUSHJ P,IDSUB
00040 MOVEI AR1,1
00050 PUSHJ P,INTER1 ;is it in oblist
00060 POPJ P, ;found it
00070 MOVE A,AR2A ;not there
00080 JRST MAKID2 ;put it there
00090
00100 REMOB: JUMPE A,FALSE
00110 MOVEI AR1,1
00120 PUSH P,A
00130 HLRZ A,(A)
00140 PUSHJ P,INTERN
00150 HLRZ B,@(P)
00160 CAME A,B
00170 JRST REMOB2
00180 CAIN A,NIL ;*** AVERT POTENTIAL DISASTER
00190 ERR2 [SIXBIT /CAN'T REMOB NIL!/]
00200 HRRZ B,CURBUC
00210 REMOTE<
00220 RHX5:
00230 XXX2: XWD B,OBTBL>
00240 HLRZ C,@RHX5
00250 HLRZ T,(C)
00260 CAMN T,A
00270 JRST [ HRRZ TT,(C)
00280 HRLM TT,@RHX5
00290 JRST REMOB2]
00300 REMOB3: MOVE TT,C
00310 HRRZ C,(C)
00320 HLRZ T,(C)
00330 CAME T,A
00340 JRST REMOB3
00350 HRRZ T,(C)
00360 HRRM T,(TT)
00370 REMOB2: POP P,A
00380 HRRZ A,(A)
00390 JRST REMOB
00400
00410 ;*** ROUTINE TO COMPARE PNAMES FOR EQUALITY WITHOUT INTERNING
00420 EQSTR: MOVE C,[JUMPE A,EQSTR1] ;WMT- EXTEND EQSTR TO BE LIKE EQUAL
00430 MOVEM C,EQUALX ;WMT- TELL EQUAL TO USE EQSTR
00440 JRST EQUAL0
00450 EQSTR1: MOVE A,(P) ;WMT- SAVE FOR EQUAL
00460 MOVEM C,(P) ;WMT- SAVE EXIT P
00470 PUSHJ P,PNAMUK ;GET PNAME OF 1ST ARG
00480 PUSHJ P,IDSUB
00490 MOVEI AR1,1
00500 MOVE 1,TT ;WMT- GET SECOND ARGUMENT
00510 PUSHJ P,CMPNAM ;GO DO COMPARE
00520 JRST COMP3A ;WMT- DIFFERENT. GO CLEAN UP
00530 JRST COMP3B ;WMT- SAME. GO ON.
00540 PAGE
00010 ;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
00020 ;READ CHARACTER-TABLE BY LISP FUNCTIONS
00030 ;TAKES TWO ARGUMENTS A,B
00040 ; IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
00050 ; LOCATION SPECIFIED BY A
00060 ; OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
00070 ; TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
00080 ; PREVIOUS VALUE
00090
00100 MODCHR: PUSH P,B ;$$SAVE BIT PATTERN FOR TABLE
00110 PUSHJ P,NUMVAL ;$$GET POSITION IN TABLE
00120 POP P,B ;$$
00130 MOVE T,CHRTAB(A) ;$$GET OLD TABLE VALUE
00140 JUMPE B,MCEXIT ;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
00150 PUSH P,A ;$$SAVE TABLE POSITION
00160
00170 MOVEI A,(B) ;$$
00180 PUSHJ P,NUMVAL ;$$GET NEW BIT PATTERN
00190 POP P,B ;$$GET TABLE POSITION
00200 MOVEM A,CHRTAB(B) ;$$CHANGE TABLE
00210 LDB A,[POINT R,CHRTAB(B),5] ;*** IS THIS A SLASH CHAR?
00220 CAIN A,SLCHAR ;***
00230 MOVEM B,SLASHC ;*** SAVE FOR SUBSEQUENT PRINTING
00240 MCEXIT: MOVE A,T ;$$RETURN OLD TABLE VALUE
00250 JRST FIX1A ;$$CONVERT TO BINARY AND EXIT
00260
00270 ;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
00280 ; CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
00290 ; CHARACTER OF THE PRINT NAME
00300 CHRVAL: MOVEI B,PNAME(S) ;$$ GET PRINT NAME
00310 PUSHJ P,GET ;$$
00320 HLRZ A,(A) ;$$
00330 MOVE A,(A) ;$$ FIRST WORD OF PRINT NAME
00340 LSH A,-35 ;$$ SHIFT TO GET FIRST CHARACTER
00350 JRST FIX1A ;$$ CONVERT TO INTEGER
00360
00370 ;FUNCTION TO SET BITS FOR A READ MACRO
00380 ; A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
00390 ; IF B=NIL NO MODIFICATION IS MADE
00400 ; THE OLD STATUS BITS ARE RETURNED
00410 SETCHR: MOVE TT,B ;$$
00420 PUSHJ P,CHRVAL ;$$ CONVERT CHAR. TO INUM
00430 MOVEI B,-INUM0(A) ;$$ CONVERT INUM TO BINARY
00440 LDB A,[POINT 5,CHRTAB(B),5] ;$$ LOAD OLD BITS
00450 JUMPE TT,FIX1A ;$$ NO CHANGE IF B = NIL
00460 MOVEI TT,-INUM0(TT) ;$$ CONVERT STATUS TO BINARY
00470 DPB TT,[POINT 5,CHRTAB(B),5] ;$$ SET NEW BITS
00480 JRST FIX1A ;$$ RETURN
00490
00500
00510 PAGE
00010 SUBTTL LISP INTERPRETER SUBROUTINES
00020
00030 CADDDR: SKIPA A,(A)
00040 CADDAR: HLRZ A,(A)
00050 CADDR: SKIPA A,(A)
00060 CADAR: HLRZ A,(A)
00070 CADR: SKIPA A,(A)
00080 CAAR: HLRZ A,(A)
00090 CAR: HLRZ A,(A)
00100 POPJ P,
00110
00120 CDDDDR: SKIPA A,(A)
00130 CDDDAR: HLRZ A,(A)
00140 CDDDR: SKIPA A,(A)
00150 CDDAR: HLRZ A,(A)
00160 CDDR: SKIPA A,(A)
00170 CDAR: HLRZ A,(A)
00180 CDR: HRRZ A,(A)
00190 POPJ P,
00200
00210 CAADDR: SKIPA A,(A)
00220 CAADAR: HLRZ A,(A)
00230 CAADR: SKIPA A,(A)
00240 CAAAR: HLRZ A,(A)
00250 JRST CAAR
00260
00270 CDADDR: SKIPA A,(A)
00280 CDADAR: HLRZ A,(A)
00290 CDADR: SKIPA A,(A)
00300 CDAAR: HLRZ A,(A)
00310 JRST CDAR
00320
00330 CAAADR: SKIPA A,(A)
00340 CAAAAR: HLRZ A,(A)
00350 JRST CAAAR
00360
00370 CDDADR: SKIPA A,(A)
00380 CDDAAR: HLRZ A,(A)
00390 JRST CDDAR
00400
00410 CDAADR: SKIPA A,(A)
00420 CDAAAR: HLRZ A,(A)
00430 JRST CDAAR
00440
00450 CADADR: SKIPA A,(A)
00460 CADAAR: HLRZ A,(A)
00470 JRST CADAR
00480 PAGE
00010 QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
00020 POPJ P,
00030
00040 AASCII: PUSHJ P,NUMVAL
00050 LSH A,↑D29
00060 PUSHJ P,FWCONS
00070 PUSHJ P,NCONS
00080 PNGNK1: PUSHJ P,NCONS
00090 MOVEI B,PNAME(S)
00100 PUSHJ P,XCONS
00110 ACONS: TROA B,-1
00120 NCONS: TRZA B,-1
00130 XCONS: EXCH B,A
00140 CONS: AOS CONSVAL
00150 HRL B,A
00160 SKIPN A,F
00170 JRST [ HLR A,B
00180 PUSHJ P,AGC
00190 JRST .-1]
00200 MOVE F,(F)
00210 MOVEM B,(A)
00220 POPJ P,
00230
00240 ;new consing routines-not finished yet
00250 ;acons: troa b,-1
00260 ;ncons: trz b,-1
00270 ;cons: exch b,a
00280 ;xcons: hrl a,b
00290 ; exch a,(f)
00300 ; exch a,f
00310 ; popj p,
00320
00330 CONSP: JUMPE A,CPOPJ ;## DONE IF NIL
00340 CAIGE A,@GCP1 ;*** MUST BE IN FS
00350 CAIGE A,@GCPP1 ;***
00360 JRST FALSE
00370 HLLE B,(A)
00380 AOJE B,FALSE
00390 IFN NONUSE <JRST TRUE> ;## T IF NONUSEFUL DESIRED
00400 IFE NONUSE <POPJ P,> ;## THE CELL OTHERWISE
00410 PATOM: CAIGE A,@GCP1 ;*** T IF NOT IN FS
00420 CAIGE A,@GCPP1
00430 JRST TRUE
00440 JRST PATOM1
00450 ATOM: CAILE A,INUMIN
00460 JRST TRUE
00470 JUMPE A,TRUE ;## FAST CHECK FOR NIL
00480 CAIGE A,@GCP1 ;## LO-END OF FWS
00490 CAIGE A,@GCPP1 ;*** LO-END OF FS
00500 JRST FALSE ;*** NOT IN FS
00510 PATOM1: HLLE A,(A)
00520 AOJE A,TRUE
00530 FALSE: MOVEI A,NIL
00540 CPOPJ: POPJ P,
00550 PAGE
00010 NEQ: CAMN A,B
00020 JRST FALSE
00030 JRST TRUE
00040 EQ: CAMN A,B
00050 JRST TRUE
00060 JRST FALSE
00070
00080 LENGTH: MOVEI B,0
00090 LNGTH1: JUMPE A,FIX1 ;## DONE IF NIL
00100 CAIL A,@FWSO ;## FWSO IS FULL SPACE ORIGIN,
00110 ;## ELIMINATE ILL MEM REF
00120 JRST FIX1
00130 HLLE C,(A)
00140 AOJE C,FIX1
00150 HRRZ A,(A)
00160 AOJA B,LNGTH1
00170
00180 LAST: HRRZ B,(A)
00190 CAIE B,NIL ;## IF NIL DONE
00200 CAIL B,@FWSO ;## ANOTHER POTENTIAL ILL MEM GONE
00210 POPJ P,
00220 HLLE B,(B)
00230 AOJE B,CPOPJ
00240 HRRZ A,(A)
00250 JRST LAST
00260
00270 ;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
00280 LITATOM: MOVE B,A
00290 PUSHJ P,ATOM
00300 JUMPE A,CPOPJ
00310 MOVE A,B
00320 PUSHJ P,NUMBERP
00330 JRST NOT
00340 PAGE
00010 ;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO CLOBBER NIL AND ATOMS
00020 RPLACA: CAIE A,NIL ;## TEST FOR NIL
00030 CAILE A,INUMIN ;$$
00040 JRST RPAERR ;$$ ATTEMPT TO RPLACA A SMALL NUMBER
00050 HLL A,(A) ;$$TEST FOR OTHER ATOMS
00060 TLC A,-1 ;$$
00070 TLZN A,-1 ;$$ATOM CARS ARE -1
00080 JRST RPAERR ;$$ATTEMPT TO RPLACA AN ATOM
00090 HRLM B,(A) ;$$STANDARD CODE FOR RPLACA
00100 POPJ P, ;$$
00110
00120 RPLACD: CAIG A,INUMIN ;$$CHECK FOR SMALL BER
00130 JUMPN A,.+2 ;$$CHECK FOR NIL
00140 JRST RPDERR ;$$ATTEMPT TO RPLACD NIL OR A SMALL NUMBER
00150 HRRM B,(A) ;$$OLD RPLACD CODE
00160 POPJ P, ;$$
00170
00180 ZEROP: PUSHJ P,NUMVAL
00190 NOT:
00200 NULL: JUMPN A,FALSE
00210 TRUE:
00220 MOVEI A,TRUTH(S)
00230 POPJ P,
00240
00250 FW0CNS: MOVEI A,0
00260 FWCONS: JUMPN FF,FWC1
00270 EXCH A,FWC0#
00280 PUSHJ P,AGC
00290 EXCH A,FWC0
00300 FWC1: EXCH A,(FF)
00310 EXCH A,FF
00320 POPJ P,
00330
00340 PAGE
00010 SASSOC: PUSHJ P,SAS1
00020 SKIPA A,C ;*** USE APPLY INSTEAD OF UUO
00030 POPJ P,
00040 MOVEI B,NIL
00050 JRST AP2
00060
00070 ASSOC: PUSHJ P,SAS1
00080 MOVEI A,NIL
00090 POPJ P,
00100
00110 SAS0: HLRZ B,T
00120 SAS1: JUMPE B,CPOPJ
00130 MOVS T,(B)
00140 MOVS TT,(T)
00150 CAIE A,(TT)
00160 JRST SAS0
00170 HRRZ A,T
00180 CPOPJ1: AOS (P)
00190 POPJ P,
00200
00210 REVERSE: MOVE T,A
00220 MOVEI A,0
00230 JUMPE T,CPOPJ
00240 HLRZ B,(T)
00250 HRRZ T,(T)
00260 PUSHJ P,XCONS
00270 JUMPN T,.-3
00280 POPJ P,
00290
00300 REMPROP:
00310 IFE OLDNIL< CAIN A,NIL ;*** IF NEW NIL GET FAKE ATOM HEADER
00320 MOVEI A,FAKNIL(S)>
00330 HRRZ T,(A)
00340 REMP2: MOVS TT,(T)
00350 CAIN B,(TT)
00360 JRA TT,REMP1
00370 HLRZ A,TT
00380 HRRZ T,(A)
00390 JUMPN T,REMP2
00400 JRST FALSE
00410
00420 REMP1: HRRM TT,(A)
00430 JRST TRUE
00440 PAGE
00010 GET:
00020 IFE OLDNIL< CAIN A,NIL ;*** IF NEW NIL GET FAKE ATOM HEADER
00030 MOVEI A,FAKNIL(S)>
00040 HRRZ A,(A)
00050 GET1: MOVS D,(A)
00060 CAIN B,(D)
00070 JRST CADR
00080 HLRZ A,D
00090 HRRZ A,(A)
00100 JUMPN A,GET1
00110 POPJ P,
00120
00130 GETL: JUMPE B,FALSE ;$$ NIL LIST - NIL ANSWER
00140 IFE OLDNIL< CAIN A,NIL ;*** IF NEW NIL GET FAKE ATOM HEADER
00150 MOVEI A,FAKNIL(S)>
00160 HRRZ A,(A)
00170 GETL0: HLRZ T,(A)
00180 MOVE C,B
00190 GETL1: MOVS TT,(C)
00200 CAIN T,(TT)
00210 POPJ P,
00220 HLRZ C,TT
00230 JUMPN C,GETL1
00240 HRRZ A,(A)
00250 HRRZ A,(A)
00260 JUMPN A,GETL0
00270 POPJ P,
00280
00290 NUMBERP:PUSHJ P,NUMTYP ;WMT- GO GET TYPE OF NUMBER
00300 JUMPN A,TRUE ; IF IT HAD A TYPE
00310 NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
00320
00330 STRINGP: PUSHJ P,LITATOM ;*** LEAVES A IN B
00340 JUMPE A,CPOPJ ;***
00350 MOVE A,B
00360 PUSHJ P,CHRVAL ;GET THE FIRST CHARACTER
00370 SUBI A,INUM0 ;***
00380 LDB B,RATFLD ;*** SEE IF DEFINED AS STRING START
00390 CAIE B,STRBEG ;***
00400 JRST FALSE
00410 JRST TRUE
00420
00430 PUTPROP:
00440 IFE OLDNIL< CAIN A,NIL ;*** IF NEW NIL GET FAKE ATOM HEADER
00450 MOVEI A,FAKNIL(S)>
00460 MOVE T,A
00470 HRRZ A,(A)
00480 CSET3: MOVS TT,(A)
00490 HLRZ A,TT
00500 CAIN C,(TT)
00510 JRST CSET2
00520 HRRZ A,(A)
00530 JUMPN A,CSET3
00540 HRRZ A,(T)
00550 PUSHJ P,XCONS
00560 HRRZ B,C
00570 PUSHJ P,XCONS
00580 HRRM A,(T)
00590 JRST CADR
00600
00610 CSET2: CAIE C,VALUE(S)
00620 JRST CSET1
00630 HRRZ T,(B)
00640 HLRZ A,(A)
00650 HRRM T,(A)
00660 JRST PROG2
00670
00680 CSET1: HRLM B,(A)
00690 PROG2: MOVE A,B
00700 PROG1: POPJ P,
00710 PAGE
00010 DEFPROP:
00020 HRRZ B,(A)
00030 HRRZ C,(B)
00040 HLRZ A,(A)
00050 HLRZ B,(B)
00060 HLRZ C,(C)
00070 PUSH P,A
00080 PUSHJ P,PUTPROP
00090 JRST POPAJ
00100
00110 ;*** New Super (DEFLIST <l> <defval> <prop>)
00120 DEFLIST: HRRZ B,(A)
00130 HRRZ C,(B)
00140 JUMPN C,.+4
00150 MOVE C,B ;*** MISSING <defval> ==> T
00160 MOVEI B,TRUTH(S)
00170 SKIPA
00180 HLRZ B,(B)
00190 HLRZ A,(A)
00200 HLRZ C,(C)
00210 JUMPE A,CPOPJ
00220 PUSH P,B ;*** SAVE DEFAULT VALUE
00230 PUSH P,C ;*** SAVE PROPERTY
00240 DEFL1: PUSH P,A ;*** SAVE LIST
00250 HLRZ A,(A) ;*** GET ATOM OR (ATOM VALUE) PAIR
00260 HLLE AR1,(A) ;*** ATOM OR PAIR?
00270 AOJE AR1,.+5 ;*** ATOM - USE DEFAULT VALUE
00280 HRRZ B,(A) ;*** PAIR - USE VALUE GIVEN
00290 HLRZ B,(B)
00300 HLRZ A,(A)
00310 SKIPA
00320 HRRZ B,-2(P)
00330 HRRZ C,-1(P)
00340 PUSHJ P,PUTPROP
00350 POP P,A
00360 HRRZ A,(A)
00370 JUMPN A,DEFL1
00380 SUB P,[XWD 2,2]
00390 JRST CPOPJ
00400
00410 ;*** (DEFP A B C) = (PROGN (PUTPROP @A (GET @B @C) @C) @A)
00420 DEFP: HLRZ B,(A)
00430 PUSH P,B
00440 HRRZ B,(A)
00450 HLRZ A,(B)
00460 HRRZ B,(B)
00470 HLRZ B,(B)
00480 PUSHJ P,GET
00490 MOVE C,B
00500 MOVE B,A
00510 MOVE A,0(P)
00520 PUSHJ P,PUTPROP
00530 JRST POPAJ
00540
00550 ;*** (DEFV A B) = (PROGN (SETQ A @B) @A)
00560 DEFV: HRRZ B,(A)
00570 HLRZ B,(B)
00580 HLRZ A,(A)
00590 PUSH P,A
00600 PUSHJ P,SET
00610 JRST POPAJ
00620 PAGE
00010 EQUAL: MOVE C,[JUMPE A,EQUAL4] ;WMT- FAIL IF NON-NUMERIC ATOMS THAT AREN'T EQ
00020 MOVEM C,EQUALX ;WMT-
00030 EQUAL0: MOVE C,P
00040 EQUAL1: CAMN A,B
00050 JRST TRUE
00060 DMOVE T,A
00070 PUSHJ P,ATOM
00080 EXCH A,B
00090 PUSHJ P,ATOM
00100 CAMN A,B
00110 JRST EQUAL3
00120 EQUAL4: MOVE P,C
00130 JRST FALSE
00140
00150 REMOTE<
00160 EQUALX: JUMPE A,EQUAL4> ;WMT- DO THIS IF NON-NUMERIC, NON-EQ ATOMS
00170
00180 EQUAL3: PUSH P,T
00190 JUMPN A,EQ2
00200 PUSH P,TT
00210 HLRZ A,(T)
00220 HLRZ B,(TT)
00230 PUSHJ P,EQUAL1
00240 JUMPE A,EQUAL4
00250 POP P,B
00260 POP P,A
00270 HRRZ A,(A)
00280 HRRZ B,(B)
00290 JRST EQUAL1
00300
00310 EQ2: MOVE A,T
00320 PUSHJ P,NUMBERP
00330 XCT EQUALX ;WMT- DO SOMETHING DIFFERENT IF EQSTR
00340 MOVE A,TT
00350 PUSHJ P,NUMBERP
00360 JUMPE A,EQUAL4
00370 MOVE A,(P)
00380 MOVEM C,(P)
00390 MOVE B,TT
00400 JSP C,OP
00410 JRST COMP3 ;*** CHANGED FROM JUMPL 7/27/76
00420 JRST COMP3 ;*** DITTO
00430
00440 COMP3B: SKIPA A,TT ;WMT- EQSTR SUCCEEDED. MAKE THIS WORK
00450 COMP3A: SETCM A,TT ;WMT- EQSTR FAILED. MAKE THIS FAIL
00460 COMP3: POP P,C
00470 CAME A,TT
00480 JRST EQUAL4
00490 JRST TRUE
00500 PAGE
00010 COMMENT ?
00020 ;## OLD SUBST AND COPY CODE THAT DID NOT WORK AS IT WAS
00030 ;## NOT PROTECTED FROM THE GARBAGE COLLECTOR. NASTY, NASTY.
00040 ;## REPLACED BY COMPILED LISP CODE
00050 SUBS5: HRRZ A,SUBAS
00060 POPJ P,
00070
00080 SUBST: MOVEM A,SUBAS#
00090 MOVEM B,SUBBS#
00100 SUBS0A: MOVE A,SUBAS
00110 MOVE B,SUBBS
00120 PUSH P,C
00130 MOVE A,C
00140 PUSHJ P,EQUAL
00150 POP P,C
00160 JUMPN A,SUBS5
00170 CAIE C,NIL ;## TEST FOR NIL
00180 CAILE C,INUMIN
00190 JRST EV6A
00200 HLLE T,(C)
00210 AOJN T,SUBS2
00220 EV6A: MOVE A,C
00230 POPJ P,
00240
00250 SUBS2: PUSH P,C
00260 HLRZ C,(C)
00270 PUSHJ P,SUBS0A
00280 EXCH A,(P)
00290 HRRZ C,(A)
00300 PUSHJ P,SUBS0A
00310 POP P,B
00320 JRST XCONS
00330
00340 COPY: MOVEI B,INUM0 ;$$ (SUBST 0 0 A)
00350 MOVEI C,INUM0
00360 EXCH A,C
00370 JRST SUBST
00380 ?
00390 PAGE
00010 ; NTHCHAR = THE BTH CHARACTER OF A.
00020 ; *** USED TO TREAT LITATOMS AS A SPECIAL CASE FOR EFFICIENCY
00030 ; *** BUT STRINGS WERE HANDLED INCORRECTLY. FIXED TO HANDLE
00040 ; *** ALL OBJECTS VIA PRINTA
00050 NTHCHAR: SUBI B,INUM0
00060 JUMPGE B,NTH3
00070 MOVEM B,ORGSGN
00080 PUSH P,A
00090 PUSHJ P,%FLATSIZEC
00100 MOVEI B,1-INUM0(A)
00110 ADD B,ORGSGN
00120 POP P,A
00130 NTH3: JUMPLE B,FALSE ;*** IN CASE N = 0 OR IS TOO BIG (NEG)
00140 MOVEM B,ORGSGN
00150 HRROI R,NTH5 ;I HOPE THIS IS RIGHT
00160 PUSHJ P,PRINTA
00170 HLRZ A,ORGSGN
00180 JUMPE A,FALSE ;*** IN CASE N TOO BIG (POS)
00190 PUSHJ P,AASCII+1 ;CONVERT TO AN ATOM
00200 JRST INTERN ;INTERN IT
00210 NTH5: SOSN ORGSGN
00220 HRLOM A,ORGSGN
00230 POPJ P,
00240 PAGE
00010 NCONC: TDZA R,R
00020 APPEND: MOVEI R,.APPEND-.NCONC
00030 JUMPE T,FALSE
00040 POP P,B
00050 APP2: AOJE T,PROG2
00060 POP P,A
00070 PUSHJ P,.NCONC(R)
00080 MOVE B,A
00090 JRST APP2
00100
00110 .NCONC: JUMPE A,PROG2 ;*** THIS IS *NCONC
00120 MOVE TT,A
00130 MOVE C,TT
00140 HRRZ TT,(C)
00150 JUMPN TT,.-2
00160 HRRM B,(C)
00170 POPJ P,
00180
00190 .APPEND: JUMPE A,PROG2 ;*** THIS IS *APPEND
00200 MOVEI C,AR1
00210 MOVE TT,A
00220 APP1: HLRZ A,(TT)
00230 PUSH P,B
00240 PUSHJ P,CONS ;saves b
00250 POP P,B
00260 HRRM A,(C)
00270 MOVE C,A
00280 HRRZ TT,(TT)
00290 JUMPN TT,APP1
00300 JRST SUBS4
00310 PAGE
00010 ;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
00020 ; THE ELEMENT IS FOUND
00030
00040 IFE NONUSE<MEMBER:
00050 >
00060 MEMBR.: PUSHJ P,MEMB0
00070 SKIPE A
00080 MOVE A,SUBBS
00090 POPJ P,
00100
00110 IFN NONUSE<MEMBER:
00120 >
00130 MEMB0: MOVEM A,SUBAS#
00140 MEMB1: JUMPE B,FALSE
00150 MOVEM B,SUBBS#
00160 MOVE A,SUBAS
00170 HLRZ B,(B)
00180 PUSHJ P,EQUAL
00190 JUMPN A,CPOPJ
00200 MOVE B,SUBBS
00210 HRRZ B,(B)
00220 JRST MEMB1
00230
00240 IFN NONUSE<
00250 MEMQ: PUSHJ P,MEMB
00260 SKIPE A
00270 JRST TRUE
00280 POPJ P,
00290 >
00300 IFE NONUSE<MEMQ:
00310 >
00320 MEMB: EXCH A,B ;## NEW MEMQ THAT RETURN TAIL
00330 JUMPE A,FALSE
00340 MOVS C,(A)
00350 CAIN B,(C)
00360 POPJ P,
00370 HLRZ A,C ;*** DOES NOT WORK WITH NON-LISTS
00380 JUMPN A,MEMB+1
00390 POPJ P,
00400
00410
00420
00430 PAGE
00010 IFN NONUSE<
00020 ;AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
00030 ; THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
00040
00050 AND.: PUSHJ P,AND
00060 SKIPA
00070 OR.: PUSHJ P,OR
00080 HRRZ A,2(P)
00090 POPJ P,
00100 >
00110
00120 AND: HRLI A,TRUTH(S)
00130 OR: HLRZ C,A
00140 PUSH P,C
00150 ANDOR: HRRZ C,A
00160 JUMPE C,AOEND
00170 MOVSI C,(SKIPE (P))
00180 TLNE A,-1
00190 MOVSI C,(SKIPN (P))
00200 XCT C
00210 JRST AOEND
00220 MOVEM A,(P)
00230 HLRZ A,(A)
00240 PUSHJ P,EVAL
00250 EXCH A,(P)
00260 HRR A,(A)
00270 JRST ANDOR
00280
00290 AOEND: POP P,A
00300 IFN NONUSE <
00310 SKIPE A
00320 MOVEI A,TRUTH(S)
00330 >
00340 POPJ P,
00350 PAGE
00010 GENSYM: MOVE B,[POINT 7,GNUM,34]
00020 MOVNI C,4
00030 MOVEI TT,"0"
00040
00050 GENSY2: LDB T,B
00060 AOS T
00070 DPB T,B
00080 CAIG T,"9"
00090 JRST GENSY1
00100 DPB TT,B
00110 ADD B,[XWD 70000,0]
00120 AOJN C,GENSY2
00130
00140 GENSY1: MOVE A,GNUM
00150 PUSHJ P,FWCONS
00160 PUSHJ P,NCONS
00170 JRST PNGNK1
00180
00190 REMOTE<
00200 GNUM: ASCII /G0000/>
00210
00220 CSYM: HLRZ A,(A)
00230 PUSH P,A
00240 MOVEI B,PNAME(S)
00250 PUSHJ P,GET
00260 JUMPE A,NOPNAM
00270 HLRZ A,(A)
00280 MOVE A,(A)
00290 MOVEM A,GNUM
00300 JRST POPAJ
00310 PAGE
00010 LIST: MOVEI B,CEVAL(S)
00020 PUSH P,B
00030 PUSH P,A
00040 MOVNI T,2
00050 JRST MAPCAR
00060
00070 EELS: HLRZ TT,(T) ;interpret lsubr call
00080 JUMPE TT,UNDFUN ;*** NIL NOT A VALID PROPERTY
00090 HRRZ A,(AR1)
00100 ILIST: MOVEI T,0
00110 JUMPE A,ILIST2
00120 ILIST1: PUSH P,A
00130 HLRZ A,(A)
00140 PUSH P,TT
00150 HRLM T,(P)
00160 PUSHJ P,EVAL ;EVALUATE ARGUMENT
00170 ILIST3: POP P,TT
00180 HLRE T,TT
00190 EXCH A,(P)
00200 HRRZ A,(A)
00210 SOS T
00220 JUMPN A,ILIST1
00230 ILIST2: JRST (TT)
00240
00250 ;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
00260 .MAPC: PUSH P,A
00270 JUMPE B,PRETB
00280 HLRZ A,(B)
00290 HRRZ B,(B)
00300 PUSH P,B
00310 CALLF 1,@-1(P)
00320 POP P,B
00330 JRST .MAPC+1
00340
00350 ;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
00360 .MAP: PUSH P,A
00370 JUMPE B,PRETB
00380 MOVE A,B
00390 HRRZ B,(B)
00400 PUSH P,B
00410 CALLF 1,@-1(P)
00420 POP P,B
00430 JRST .MAP+1
00440
00450 PRETB: SUB P,[XWD 1,1]
00460 JRST PROG2
00470 PAGE
00010 ; NEW AND SUPER POWERFUL MAP FUNCTIONS
00020 MAPCON: TLZ T,100000
00030 JRST MAPLIST
00040 MAPCAN: TLZA T,100000
00050 MAPC: TLZA T,400000
00060 MAPCAR: TLZA T,400000
00070 MAP: TLZ T,200000
00080 ; INITIALIZE
00090 MAPLIST:SETCA T,T ; RH(T) NOW = # ARGS FOR MAP
00100 HRRZ A,T ; GET NUMBER OF ARGS TO MAP
00110 CAIGE A,1 ; WE NEED AT LEAST A FUN. AND 1 ARG.
00120 ERR1 [SIXBIT /TOO FEW ARGUMENTS - MAP!/]
00130 MOVEI A,(CALLF)
00140 DPB T,[POINT 4,A,30]
00150 MOVE B,P
00160 MOVE AR1,T
00170 HRL AR1,T
00180 SUB B,AR1
00190 PUSH P,B
00200 HRLM A,(B)
00210 PUSH P,T
00220 PUSH P,
00230 HRLZM P,(P)
00240 ; SET UP TO GET ARGUMENTS
00250 MAPL2: MOVE T,-1(P) ; GET # ARGS FOR FUN CALL
00260 MOVEI TT,-3(P) ; GET ADDR OF REG. FOR LAST (TOPMOST) ARG
00270 ; MOVE ARGS TO REGS
00280 MPL3: MOVE D,(TT) ; PICK AN ARG FROM IN THE STACK
00290 TLNE T,40000 ;WMT-SKIP IF FIRST TIME THRU ARGS
00300 MPL4: HRRZ D,(D) ;WMT-TAKE CDR
00310 JUMPE D,MPDN ; (WE'RE DONE IF IT'S NIL)
00320 ; [UT] CHECK FOR WELL FORMED LIST (IE., NOT AN ATOM)
00330 CAILE D,INUMIN ; [UT]
00340 JRST MAPERR ; IT'S AN INUM [UT]
00350 HLLE R,(D) ; GET LEFT HALF (-1 FOR ATOM HEADER) [UT]
00360 AOJE R,MAPERR ; ZERO => IT WAS AN ATOM HEADER [UT]
00370 ;WMT-CHANGES TO MAKE RPLACD WORK DURING MAP,MAPLIST,MAPCON
00380 HRRZM D,(TT) ;WMT-STORE IT BACK FOR NEXT TIME
00390 MOVEM D,(T) ; PUT ARG IN APPROPRIATE REG.
00400 MOVE D,(D) ; GET FIRST CONS CELL OF LIST
00410 TLNE T,400000 ; SKIP TO USE FULL LIST(MAP,MAPLIST,MAPCON)
00420 HLRZM D,(T) ; ELSE USE CAR OF LIST (MAPCAR,MAPC,MAPCAN)
00430 COMMENT & (ABOVE CODE DOES THIS BETTER)
00440 ; [UT] CHECK THAT WE'RE NOT MAPPING DOWN AN ILL-FORMED LIST
00450 HRRZS D,D ; CHECK CDR IS NOT A NON-NIL ATOM [UT]
00460 EXCH A,D ; SAVE REG.A IN CASE IT'S ALREADY SET [UT]
00470 CAIE A,0 ; SKIP IF NIL [UT]
00480 PUSHJ P,PATOM ; THOROUGH ATOM CHECK [UT]
00490 CAIN A,TRUTH(S) ; WAS IT A NON-NIL ATOM? [UT]
00500 JRST MAPERR ; YES--MAP ARG NOT A LIST [UT]
00510 EXCH A,D ; RESTORE AND CONTINUE... [UT]
00520 &
00530 SUBI TT,1
00540 SUBI T,1 ;WMT-SUBTRACT ONE FROM # OF ARGS
00550 TRNE T,777777 ;WMT-ARE WE THROUGH?
00560 JRST MPL3 ;WMT-NOPE, DO NEXT ARG
00570 TLON T,40000 ;WMT-MARK THAT YOU'VE DONE LIST ONCE
00580 HLLM T,-1(P) ;WMT-SAVE MARK FOR LATER
00590 XCT (TT) ; CALL THE FUNCTION
00600 LDB C,[POINT 2,-1(P),2]
00610 TRNE C,2
00620 JRST MAPL2
00630 ; ATTACH TO OUTPUT LIST
00640 SKIPN C
00650 PUSHJ P,NCONS
00660 JUMPE A,MAPL2
00670 HLR B,(P)
00680 HRRM A,(B)
00690 SKIPE C
00700 PUSHJ P,LAST
00710 HRLM A,(P)
00720 JRST MAPL2
00730 ; POP STACK AND RETURN
00740 MPDN: POP P,AR1
00750 MOVE P,-1(P)
00760 POP P,B
00770 SUBS4: HRRZ A,AR1
00780 POPJ P,
00790
00800 MAPERR: ERR1 [SIXBIT /ILL-FORMED ARGUMENT - MAP!/]
00810
00820 ;PA3: 0 ;THE REG. PDL POINTER
00830 ;PA4: 0 ;Lh=pntr to prog less bound var list
00840 ;RH=NEXT PROG STATEMENT
00850
00860 PROG: PUSH P,PA3#
00870 PUSH P,PA4#
00880 HLRZ TT,(A) ;## TT HAS VARIABLE LIST
00890 HRRZ A,(A) ;## A HAS PROG BODY
00900 HRRM A,PA4
00910 HRLM A,PA4
00920
00930 MOVE T,SP ;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
00940 SUB T,[XWD 2,2] ;$$SO PA3,PA4 CAN BE RESTORED
00950 MOVEM T,SPSV# ;$$BY UNBIND
00960 JRST PG7B ;$$GO CHECK IF ANY VARIABLES TO BIND
00970
00980 PG7A: HLRZ A,(TT)
00990 MOVEI AR1,0
01000 PUSHJ P,BIND
01010 HRRZ TT,(TT)
01020 PG7B: JUMPN TT,PG7A
01030 PUSH SP,SPSV
01040 MOVEM P,PA3
01050
01060 PG1: HRRZ T,PA4
01070 JUMPE T,PG4 ;## IF END OF PROG, QUIT
01080 HLRZ A,(T) ;## A HAS FIRST STATEMENT
01090 HRRZ T,(T) ;## T KEEPS THE REST
01100 CAIE A,NIL ;## TEST FOR NIL
01110 CAILE A,INUMIN ;## ALLOW INUMS FOR PROG LABELS 3/28/73
01120 JRST PG1+1 ;## NOW WE CAN SKIP OVER THIS TYPE OF ATOM
01130 HLLE B,(A) ;## IS IT A ATOM?
01140 AOJE B,PG1+1 ;## JA, SO JUMP
01150 HRRM T,PA4 ;## SAVE REST OF BODY
01160
01170 PUSHJ P,EVAL ;## EVAL THE STATEMENT
01180
01190 JRST PG1
01200
01210 PGO: SKIPN PA3 ;## ERROR IF NO PROG
01220 JRST EG2
01230 MOVE P,PA3 ;## BACK UP ON RPDL
01240 MOVE B,2(P) ;*** GET SP PUSHED BY EVAL
01250 PUSHJ P,UBD
01260 HRLZI C,(POPJ P,) ;## NEW CODE TO ALLOW BREAKING
01270 ;## AND TRACING OF GO
01280 PUSHJ P,DOSET ;##
01290 HLRZ T,PA4
01300 PG5: JUMPE T,EG1 ;## ERROR IF NO TAG FOUND
01310 HLRZ TT,(T) ;## GET THE CAR
01320 HRRZ T,(T) ;## SAVE UP THE REST OF THE BODY
01330 CAIN TT,(A)
01340 JRST PG1+1 ;FOUND TAG
01350 JRST PG5 ;## TRY AGAIN
01360
01370 RETURN: SKIPN PA3
01380 JRST EG3
01390 MOVE P,PA3
01400 MOVE B,2(P) ;*** GET SP PUSHED BY EVAL
01410 PUSHJ P,UBD
01420 HRLZI C,(POPJ P,) ;## NEW CODE TO ALLOW BREAKING
01430 ;## AND TRACING OF RETURN
01440 PUSHJ P,DOSET ;##
01450 JRST PG4+1
01460
01470 PG4: SETZ A,
01480 PUSHJ P,UNBIND
01490 ERRP4: POP P,PA4
01500 POP P,PA3
01510 POPJ P,
01520
01530 GO: HLRZ A,(A)
01540 CAIE A,NIL ;## TEST FOR NIL
01550 CAILE A,INUMIN ;## IS IT AN INUM?(NOW VALID)
01560 JRST PGO ;## SEE IF IT IS THE ONE
01570 HLLE B,(A) ;## IS IT AN ATOM
01580 AOJE B,PGO
01590 PUSHJ P,EVAL
01600 JRST GO+1
01610
01620 SETQ: HLRZ B,(A)
01630 PUSH P,B
01640 PUSHJ P,CADR
01650 PUSHJ P,EVAL
01660 MOVE B,A
01670 POP P,A
01680 SET: SKIPE A ;$$ MUST BE NON-NIL
01690 CAILE A,INUMIN ;$$ AND NOT AN INUM
01700 JRST SETERR ;$$
01710 HLRE AR1,(A) ;$$ AND AN ATOM
01720 AOJN AR1,SETERR ;$$
01730 MOVE AR1,B
01740 PUSHJ P,BIND
01750 SUB SP,[XWD 1,1]
01760 RETAR1: MOVE A,AR1
01770 POPJ P,
01780
01790 CON2: HRRZ A,(T)
01800 COND: JUMPE A,CPOPJ ;entry
01810 PUSH P,A
01820 HLRZ A,(A)
01830 HLRZ A,(A)
01840 PUSHJ P,EVAL
01850 POP P,T
01860 JUMPE A,CON2
01870 HLRZ T,(T)
01880 COND2: HRRZ T,(T)
01890 JUMPE T,CPOPJ ;ENTRY FOR ALL TYPES OF PROGN'S
01900 HLRZ A,(T)
01910 HRRZ T,(T) ;$$
01920 JUMPE T,EVAL ;$$ SAVE STACK SPACE IF NO IMPLIED PROG
01930 PUSH P,T ;$$
01940 PUSHJ P,EVAL
01950 POP P,T
01960 JRST COND2+2 ;$$ BECAUSE OF THE LAST CHANGE
01970
01980
01990 ;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
02000
02010 LEXORD: MOVE TT,A
02020 PUSHJ P,NUMBERP
02030 JUMPN A,LEX2 ;1ST ARG IS A NUMBER
02040 MOVE A,B
02050 PUSHJ P,NUMBERP
02060 EXCH A,TT
02070 JUMPN TT,FALSE ;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
02080 MOVE T,B
02090 MOVEI B,PNAME(S)
02100 PUSHJ P,GET
02110 EXCH A,T
02120 PUSHJ P,GET
02130 LEX1: JUMPE T,TRUE
02140 JUMPE A,CPOPJ
02150 HLRZ AR1,(A)
02160 MOVE AR1,(AR1)
02170 HLRZ AR2A,(T)
02180 MOVE AR2A,(AR2A)
02190 LSH AR1,-1
02200 LSH AR2A,-1
02210 CAMLE AR1,AR2A
02220 JRST TRUE
02230 CAME AR1,AR2A
02240 JRST FALSE
02250 HRRZ A,(A)
02260 HRRZ T,(T)
02270 JRST LEX1
02280 LEX2: MOVE A,B
02290 PUSHJ P,NUMBERP
02300 EXCH A,TT
02310 JUMPE TT,TRUE ;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
02320 PUSHJ P,.GREAT ;BOTH NUMBERS, DO (NOT (*GREAT A B))
02330 JRST NOT
02340
02350
02360 PROGN: MOVE T,A ;$$ PROGN
02370 MOVEI A,NIL
02380 JRST COND2+1 ;$$ IMPLIED PROG DOES THE REST
02390 PAGE
00010 SUBTTL ARITHMETIC SUBROUTINES
00020
00030 ;macro expander -- (foo a b c) => (*foo (*foo a b) c)
00040 EXPAND: MOVE C,B
00050 HRRZ A,(A)
00060 PUSHJ P,REVERSE
00070 JRST EXPA1
00080
00090 EXPN1: MOVE C,B
00100 EXPA1: HRRZ T,(A)
00110 HLRZ A,(A)
00120 JUMPE T,CPOPJ
00130 PUSH P,A
00140 MOVE A,T
00150 PUSHJ P,EXPA1
00160 EXCH A,(P)
00170 PUSHJ P,NCONS
00180 POP P,B
00190 PUSHJ P,XCONS
00200 MOVE B,C
00210 JRST XCONS
00220
00230 PAGE
00010 ADD1: CAILE A,INUMIN
00020 CAIL A,-2
00030 SKIPA B,[INUM0+1]
00040 AOJA A,CPOPJ
00050 .PLUS: JSP C,OP
00060 ADD A,TT
00070 FADR A,TT
00080
00090 SUB1: CAILE A,INUMIN+1
00100 SOJA A,CPOPJ
00110 MOVEI B,INUM0+1
00120 .DIF: JSP C,OP
00130 SUB A,TT
00140 FSBR A,TT
00150
00160 .TIMES: JSP C,OP
00170 IMUL A,TT
00180 FMPR A,TT
00190
00200 .QUO: CAIN B,INUM0
00210 JRST ZERODIV
00220 JSP C,OP
00230 IDIV A,TT
00240 FDVR A,TT
00250
00260 .GREAT: EXCH A,B
00270 JUMPE B,FALSE
00280 .LESS: JUMPE A,CPOPJ
00290 JSP C,OP
00300 JRST COMP2 ;bignums know about me
00310 JRST COMP2
00320
00330 COMP2: CAML A,TT
00340 JRST FALSE
00350 JRST TRUE
00360
00370 .MAX: MOVEI D,.GREAT
00380 SKIPA
00390 .MIN: MOVEI D,.LESS
00400 MOVE AR1,A
00410 MOVE AR2A,B
00420 PUSHJ P,(D)
00430 SKIPN A
00440 MOVE AR1,AR2A
00450 JRST RETAR1
00460 PAGE
00010 MAKNUM:
00020 CAIE B,FLONUM(S) ;## DEFAULT TO FIXNUM, NOT FLONUM
00030 JRST FIX1A
00040 FLO1A:
00050 MOVEI B,FLONUM(S)
00060 PUSHJ P,FWCONS
00070 JRST ACONS-1
00080
00090 FIX1B: SUBI A,INUM0
00100 MOVEI B,FIXNUM(S)
00110 PUSHJ P,FWCONS
00120 JRST ACONS-1
00130
00140 NUMVLX: JFCL 17,.+1
00150 NUMVAL: CAIG A,INUMIN
00160 JRST NUMAG1
00170 SUBI A,INUM0
00180 MOVEI B,FIXNUM(S)
00190 POPJ P,
00200
00210 NUMAG1: MOVE REL,A ;*** CH FROM AR1
00220 HRRZ A,(A)
00230 HLRZ B,(A)
00240 HRRZ A,(A)
00250 CAIE B,FIXNUM(S)
00260 CAIN B,FLONUM(S)
00270 SKIPA A,(A)
00280 NUMV4: SKIPA A,REL ;*** DITTO
00290 POPJ P,
00300 NUMV2: PUSHJ P,EPRINT ;bignums know about me
00310 JRST NONNUM
00320
00330 NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
00340 PAGE
00010 FLOAT: IDIVI A,400000
00020 SKIPE A
00030 TLC A,254000
00040 TLC B,233000
00050 FADR A,B
00060 POPJ P,
00070
00080 FIX: PUSH P,A
00090 PUSHJ P,NUMVAL
00100 CAIE B,FLONUM(S)
00110 JRST POPAJ
00120 MULI A,400
00130 TSC A,A
00140 JFCL 17,.+1
00150 ASH B,-243(A)
00160 FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
00170 POP P,A
00180 FIX1: MOVE A,B
00190 JRST FIX1A
00200
00210 MINUSP: PUSHJ P,NUMVAL
00220 JUMPGE A,FALSE
00230 JRST TRUE
00240
00250 MINUS: PUSHJ P,NUMVLX
00260 MOVNS A
00270 JFCL 10,@OPOV
00280 JRST MAKNUM
00290
00300 ABS: PUSHJ P,NUMVLX
00310 MOVMS A
00320 JRST MINUS+2
00330
00340 NUMTYP: CAILE A,INUMIN ;WMT- IS IT AN INUM?
00350 JRST NUMTY1
00360 HLLE T,(A)
00370 AOJN T,FALSE
00380 HRRZ A,(A)
00390 HLRZ A,(A)
00400 CAIE A,FIXNUM(S)
00410 CAIN A,FLONUM(S)
00420 POPJ P,
00430 JRST FALSE
00440 NUMTY1: MOVEI A,INUM(S) ; IT'S AN INUM
00450 POPJ P,
00460
00470 INUMP: CAIG A,INUMIN ;## INUM IF > INUMIN
00480 JRST FALSE ;## NO, RETURN NIL
00490 POPJ P, ;## RETURN USEFUL VALUE
00500 PAGE
00010 DIVIDE: CAIN B,INUM0
00020 JRST ZERODIV
00030 JSP C,OP
00040 JRST RDIV ;bignums know about me
00050 JRST ILLNUM
00060 RDIV: IDIV A,TT
00070 PUSH P,B
00080 PUSHJ P,FIX1A
00090 EXCH A,(P)
00100 PUSHJ P,FIX1A
00110 POP P,B
00120 JRST XCONS
00130
00140 REMAINDER:
00150 PUSHJ P,DIVIDE
00160 JRST CDR
00170
00180 FIXOV: ERR2 [SIXBIT /INTEGER OVERFLOW!/]
00190 ZERODIV:ERR2 [SIXBIT /ZERO DIVISOR!/]
00200 FLOOV: ERR2 [SIXBIT /FLOATING OVERFLOW!/]
00210 ILLNUM: ERR2 [SIXBIT /NON-INTEGRAL OPERAND!/]
00220
00230 GCD: JSP C,OP
00240 JRST GCD2 ;bignums know about me
00250 JRST ILLNUM
00260 GCD2: MOVMS A
00270 MOVMS TT
00280 ;euclid's algorithm
00290 GCD3: CAMG A,TT
00300 EXCH A,TT
00310 JUMPE TT,FIX1A
00320 IDIV A,TT
00330 MOVE A,B
00340 JRST GCD3
00350 PAGE
00010 ;general arithmetic op code routine for mixed types
00020
00030 OP: CAIG A,INUMIN
00040 JRST OPA1
00050 SUBI A,INUM0
00060 CAIG B,INUMIN
00070 JRST OPA2
00080 HRREI TT,-INUM0(B)
00090 XCT (C) ;inum op (cannot cause overflow)
00100 FIX1A: ADDI A,INUM0
00110 CAILE A,INUMIN
00120 CAIL A,-1
00130 JRST FIX1B
00140 POPJ P,
00150
00160 OPA1: HRRZ A,(A)
00170 HLRZ T,(A)
00180 HRRZ A,(A)
00190 CAIE T,FIXNUM(S)
00200 JRST OPA6
00210 SKIPA A,(A)
00220 OPA2:
00230 MOVEI T,FIXNUM(S)
00240 CAILE B,INUMIN
00250 JRST OPB2
00260 HRRZ B,(B)
00270 HRRZ TT,(B)
00280 HLRZ B,(B)
00290 CAIE B,FIXNUM(S)
00300 JRST OPA5
00310 SKIPA TT,(TT)
00320 OPB2: HRREI TT,-INUM0(B)
00330 JFCL 17,.+1
00340 XCT (C) ;fixed pt op
00350 OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
00360 JRST FIX1A
00370
00380 OPA6: CAILE B,INUMIN
00390 JRST OPB7
00400 HRRZ B,(B)
00410 HRRZ TT,(B)
00420 HLRZ B,(B)
00430 CAIE B,FLONUM(S)
00440 JRST OPB3
00450 CAIE T,FLONUM(S)
00460 JRST NUMV3
00470 MOVE A,(A)
00480 MOVE TT,(TT)
00490 OPR: JFCL 17,.+1
00500 XCT 1(C) ;flt pt op
00510 JFCL 10,FLOOV
00520 JRST FLO1A
00530
00540 OPA5:
00550 CAIE B,FLONUM(S)
00560 JRST NUMV3
00570 PUSHJ P,FLOAT
00580 JRST OPR-1
00590
00600 OPB3:
00610 CAIE B,FIXNUM(S)
00620 JRST NUMV3
00630 SKIPA TT,(TT)
00640 OPB7: HRREI TT,-INUM0(B)
00650 MOVEI B,FIXNUM(S)
00660 CAIE T,FLONUM(S)
00670 JRST NUMV3
00680 MOVE A,(A)
00690 EXCH A,TT
00700 PUSHJ P,FLOAT
00710 EXCH A,TT
00720 JRST OPR
00730 PAGE
00010 SUBTTL EXPLODE, READLIST AND FRIENDS
00020
00030 %FLATSIZEC: SKIPA R,.+1 ;$$ FLATSIZEC - (LENGTH (EXPLODEC))
00040 FLATSIZE: HRRZI R,FLAT2
00050 SETZM FLAT1
00060 PUSHJ P,PRINTA
00070 MOVE A,FLAT1#
00080 JRST FIX1A
00090 FLAT2: AOS FLAT1
00100 POPJ P,
00110
00120
00130 %EXPLODE: SKIPA R,.+1
00140 EXPLODE: HRRZI R,EXPL1
00150 MOVSI AR1,AR1
00160 PUSHJ P,PRINTA
00170 JRST SUBS4
00180
00190 EXPL1: PUSH P,B
00200 PUSH P,C
00210 ANDI A,177
00220 CAIL A,"0"
00230 CAILE A,"9"
00240 JRST EXPL2
00250 ADDI A,INUM0-"0"
00260 JRST EXPL4
00270
00280 EXPL2: PUSH P,AR1
00290 PUSH P,TT
00300 PUSH P,T
00310 LSH A,35
00320 MOVE C,SP
00330 PUSH C,A
00340 MOVEI AR1,1
00350 PUSHJ P,INTER0
00360 POP P,T
00370 POP P,TT
00380 POP P,AR1
00390 EXPL4: PUSHJ P,NCONS
00400 HLR B,AR1
00410 HRRM A,(B)
00420 HRLM A,AR1
00430 POP P,C
00440 JRST POPBJ
00450 PAGE
00010 READLIST: TDZA T,T
00020 MAKNAM: MOVNI T,1
00030 MOVEM T,NOINFG
00040 PUSH P,OLDCH
00050 SETZM OLDCH
00060 JUMPE A,NOLIST
00070 HRRM A,MKNAM3
00080 MOVEI A,MKNAM2
00090 PUSHJ P,READ0
00100 HRRZ T,MKNAM3
00110 CAIE T,-1
00120 JUMPN T,[ERR2 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
00130 POP P,OLDCH
00140 POPJ P,
00150 MKNAM2: PUSH P,B
00160 PUSH P,T
00170 PUSH P,TT
00180 HRRZ TT,MKNAM3#
00190 JUMPE TT,MKNAM6
00200 CAIN TT,-1
00210 ERR2 [SIXBIT /READ UNHAPPY-MAKNAM!/]
00220 HRRZ B,(TT)
00230 HRRM B,MKNAM3
00240 HLRZ A,(TT)
00250 CAIGE A,INUMIN
00260 JRST MKNAM5
00270 SUBI A,INUM0-"0"
00280 MKNAM4: POP P,TT
00290 POP P,T
00300 JRST POPBJ
00310 MKNAM5: HLRZ A,(TT)
00320 MOVEI B,PNAME(S)
00330 PUSHJ P,GET
00340 HLRZ A,(A)
00350 LDB A,[POINT 7,(A),6]
00360 JRST MKNAM4
00370 MKNAM6: MOVEI A," "
00380 HLLOS MKNAM3
00390 JRST MKNAM4
00400
00410 ;A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
00420 FREE: MOVEM F,(A) ;$$ RETURN A SINGLE CELL TO FREE LIST
00430 HRRZ F,A
00440 JRST FALSE
00450 FREELI: JUMPE A,CPOPJ ;$$ RETURN A LIST TO THE FREE LIST
00460 HRRZ B,(A)
00470 MOVEM F,(A)
00480 HRRZ F,A
00490 MOVE A,B
00500 JRST FREELI
00510 PAGE
00010 SUBTTL EVAL APPLY -- THE INTERPRETER
00020
00030 APPLY.: CAILE A,INUMIN ;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
00040 JRST UNDTAG
00050 JUMPE A,UNDTAG ;*** NIL NOT A FUNCTION
00060 CAMGE A,FSO ;WMT- CHECK FOR FUNCTION IN BPS
00070 JRST APPBPS ;WMT- IT MAY BE 3/4/77
00080 HLRZ T,(A)
00090 CAIE T,-1
00100 JRST AP2 ;*** ALL AP2'S CH. FROM 'GAPP'
00110 HRRZ T,(A)
00120 AAGN: JUMPE T,AP2 ;***
00130 HLRZ TT,(T)
00140 HRRZ T,(T)
00150 CAIN TT,FSUBR(S)
00160 JRST [HLRZ T,(T)
00170 JUMPE T,UNDTAG ;*** DON'T ALLOW FSUBR PROP. OF NIL
00180 MOVE A,B
00190 JRST (T)]
00200 CAIN TT,FEXPR(S)
00210 JRST [ HLRZ T,(T)
00220 HRL T,A
00230 PUSH P,T
00240 MOVE A,B
00250 JRST APPL.2]
00260 CAIN TT,MACRO(S)
00270 JRST [ PUSHJ P,CONS
00280 JRST EVAL]
00290 CAIN TT,EXPR(S)
00300 JRST AP2 ;***
00310 CAIE TT,SUBR(S)
00320 CAIN TT,LSUBR(S)
00330 JRST AP2 ;***
00340 JRST AAGN
00350
00360 COMMENT %
00370 ;*** NO NEED TO DO THIS:
00380 GAPP: HRREI T,-2
00390 PUSH P,A
00400 PUSH P,B
00410 JRST APPLY
00420 %
00430
00440 APPBPS: CAIGE A,FS ;WMT- IS IT REALLY IN BPS
00450 JRST UNDTAG ;WMT- NO
00460 JRST AP2 ;WMT- YES, HANDLE LIKE SUBR 3/4/77
00470
00480 PAGE
00010 EV3: HLRZ A,(AR1)
00020 MOVEI B,VALUE(S)
00030 PUSHJ P,GET
00040 JUMPE A,UNDFUN ;function object has no definition
00050 HRRZ A,(A)
00060 REMOTE<
00070 XXX4:
00080 UBDPTR: UNBOUND>
00090 HLRZ B,(AR1) ;$$GET ORIGINAL FN NAME
00100 CAME A,B ;$$IF VALUE IS THE SAME THEN WE HAVE A LOOP
00110 CAMN A,UBDPTR
00120 JRST UNDFUN
00130 HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
00140 PUSHJ P,CONS
00150 JRST XXEVAL
00160
00170 ;[UT] CHECK PDL SPACE LEFT, IF TOO LITTLE WE HAVE A
00180 ; RECURSION LIMIT ERROR
00190
00200 CHKREC: PUSH P,A ;SAVE A IN CASE IT'S NEEDED
00210 HLRE A,P ;GET NEG. REG PDL WORDS REMAINING
00220 SETCA A, ;BUT WE NEED A POSITIVE NUMBER
00230 CAMGE A,REGLIM ;MORE THAN 100 WORDS LEFT?
00240 JRST RLXERR ;NO--RECURSION LIMIT EXCEEDED
00250 HLRE A,SP ;NOW CHECK SPEC PDL
00260 SETCA A,
00270 CAML A,SPELIM ;SKIP IF FEWER THAN 100 WORDS LEFT
00280 JRST NORLX ;NO ERROR--CLEAR OLD RLXFLG IF STILL SET
00290 SKIPA A,[0] ;WMT-SET FLAG TO TELL WHICH BLEW
00300 RLXERR: SETO A, ;WMT-SET FLAG TO TELL WHICH BLEW
00310 SKIPE RLXFLG# ;HAVE WE JUST PASSED THE LIMIT?
00320 JRST NORLX+1 ;NO--WE'VE BEEN HERE BEFORE, LEAVE FLG
00330 SETOM RLXFLG ;JUST PASSED LIMIT, NOTE FOR NEXT TIME
00340 SKIPE A, ;WMT-WHICH ERROR IS IT
00350 STRTIP [SIXBIT /←REG !/]
00360 SKIPN A,
00370 STRTIP [SIXBIT /←SPEC !/]
00380 POP P,A ;RESTORE REG. IN CASE IT'S NEEDED
00390 ERR1 [SIXBIT /PDL LIMIT EXCEEDED!/]
00400
00410 NORLX: SETZM RLXFLG ;CLEAR RLX FLAG, PLENTY PDL SPACE NOW
00420 JRST POPAJ
00430
00440 PAGE
00010 OEVAL: AOJN T,AEVAL ;(THIS IS LISP EVAL)
00020 POP P,A
00030 ;(THIS IS LISP *EVAL)
00040 EVAL: PUSH P,SP ;$$SAVE SPDL (*** USED BY GO AND RETURN)
00050 PUSHJ P,XXEVAL ;$$GO DO EVALUATION AS USUAL
00060 POP P,SP ;$$RESTORE SPDL
00070 POPJ P, ;$$AND RETURN TO CALLER
00080
00090 XXEVAL: HRRZM A,AR1
00100 JUMPE A,CPOPJ ;*** FAST EVAL FOR NIL
00110 CAILE A,INUMIN
00120 JRST CPOPJ
00130
00140 ;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
00150
00160 PUSH P,B ;$$SAVE WHAT WAS IN B
00170 HRRZI B,-1(P) ;$$GET RPDL POINTER AND OFFSET
00180 HRLI B,UNBOUND(S) ;$$ SET UP RPDL POINTER
00190 PUSH SP,B ;$$ SAVE RPDL POINTER ON SPDL
00200 PUSH SP,A ;$$SAVE EVAL FORM ON SPDL
00210 POP P,B ;$$AND GO ON
00220 HLRZ T,(A) ;;;;;;;;;;;;;
00230 PUSHJ P,CHKREC ;WMT-CHECK FOR PDL OVERFLOW
00240 SKIPN ERINT ;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
00250 JRST .+4 ;$$SKIP OVER INTERRUPT FEATURE
00260 SETZM ERINT ;$$TURN OFF INTERRUPT FLAG
00270 PUSHJ P,EPRINT+2 ;$$PRINT OUT WHAT WAS INTERRUPTED
00280 ERR2 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
00290 CAIN T,-1
00300 JRST EE1 ;x is atomic
00310 JUMPE T,UNDFUN ;*** NIL NOT A FUNCTION
00320 CAILE T,INUMIN
00330 JRST UNDFUN
00340 HLRO TT,(T)
00350 AOJE TT,EE2 ;car (x) is atomic
00360 JRST EXP3
00370 EE1:
00380 EV5: HRRZ AR1,(AR1)
00390 JUMPE AR1,UNBVAR
00400 HLRZ TT,(AR1)
00410 CAIE TT,FLONUM(S)
00420 CAIN TT,FIXNUM(S)
00430 POPJ P,
00440 EVBIG: HRRZ AR1,(AR1) ;bignums know about me
00450 CAIE TT,VALUE(S)
00460 JRST EV5
00470 HLRZ AR1,(AR1)
00480 HRRZ AR1,(AR1)
00490 CAIN AR1,UNBOUND(S)
00500 JRST UNBVAR
00510 JRST RETAR1
00520 PAGE
00010 ; HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
00020 ;*** SEVERAL CHANGES TO MAKE POINTERS SAME AS SPDL POINTERS
00030
00040 ALIST: MOVEM SP,SPSV
00050 SKIPN A,-1(P) ;*** GET ALIST OR SPDL POINTER
00060 JRST ALIST2 ;*** NIL - FORGET IT
00070 CAILE A,INUMIN
00080 JRST ASPEC ;*** IT'S A POINTER
00090 PUSHJ P,REVERSE ;*** IT'S AN ALIST (UGH)
00100 SKIPA ;*** NO LONGER UNBINDS ENTIRE SPDL
00110 ALIST1: MOVE A,B ;*** JUST BINDS VARS IN ALIST
00120 HRRZ B,(A)
00130 HLRZ A,(A)
00140 HRRZ AR1,(A)
00150 HLRZ A,(A)
00160 PUSHJ P,BIND
00170 JUMPN B,ALIST1
00180 ALIST2: PUSH SP,SPSV
00190 POPJ P,
00200
00210 ASPEC: MOVEI A,-INUM0(A) ;*** CONVERT TO ACTUAL STACK POINTER
00220 HLRZ TT,SC2 ;*** (WITH VALID LHS)
00230 ADD TT,A
00240 ADD A,SC2
00250 HRL A,TT
00260 MOVE C,SP
00270 ASPEC1: CAMG C,A ;*** CHECK IF UNBOUND TO DESIRED POINT
00280 JRST ALIST2 ;done
00290 POP C,T ;pointer for next block
00300 JUMPGE T,ASPEC1 ;$$SKIP ANY EVAL BLIP CRAP
00310 ASPEC2: CAMN C,T
00320 JRST ASPEC1 ;thru with block
00330 POP C,AR1
00340 TLNE AR1,-1 ;$$ TEST FOR EVAL BLIP
00350 JRST .+3
00360 SUB C,[XWD 1,1] ;$$ FOUND ONE, SKIP RPDL WORD
00370 JRST ASPEC2
00380 MOVSS AR1
00390 PUSH SP,(AR1) ;save value cell
00400 HLRM AR1,(AR1) ;store previous value in value cell
00410 HRLM AR1,(SP) ;save pointer to spec pdl loc
00420 JRST ASPEC2
00430
00440 AEVAL: PUSHJ P,ALIST
00450 POP P,A
00460 MOVEI A,UNBIND
00470 EXCH A,(P)
00480 JRST EVAL
00490 PAGE
00010 EE2: HRRZ T,(T)
00020 JUMPE T,EV3
00030 HLRZ TT,(T)
00040 HRRZ T,(T)
00050 CAIN TT,SUBR(S)
00060 JRST ESB
00070 CAIN TT,LSUBR(S)
00080 JRST EELS
00090 CAIN TT,EXPR(S)
00100 JRST AEXP
00110 CAIN TT,FSUBR(S)
00120 JRST EFS
00130 CAIN TT,MACRO(S)
00140 JRST EFM
00150 CAIE TT,FEXPR(S)
00160 JRST EE2
00170
00180 HLRZ T,(T)
00190 HLL T,(AR1)
00200 PUSH P,T
00210 HRRZ A,(A)
00220 APPL.2: TLO A,400000
00230 PUSH P,A
00240 MOVNI T,1
00250 JRST IAPPLY
00260
00270 AEXP: HLRZ T,(T)
00280 HLL T,(AR1)
00290 EXP3: PUSH P,T
00300 HRRZ A,(AR1)
00310 CILIST: JSP TT,ILIST
00320 EXP2: JRST IAPPLY
00330
00340 EFS: HLRZ T,(T)
00350 JUMPE T,UNDFUN ;*** DON'T ALLOW FSUBR PROP. OF NIL
00360 HRRZ A,(AR1)
00370 JRST (T)
00380 PAGE
00010 ESB: HRRZ A,(AR1)
00020 UUOS2: HLRZ T,(T)
00030 JUMPE T,UNDFUN ;*** DON'T ALLOW SUBR PROP. OF NIL
00040 HLL T,(AR1)
00050 PUSH P,T
00060 JSP TT,ILIST
00070 ESB1: CAMGE T,[-NACS] ;*** CHECK FOR TOO MANY ARGS
00080 JRST TOMANY ;***
00090 JRST .+NACS+1(T)
00100 POP P,A+4
00110 POP P,A+3
00120 POP P,A+2
00130 POP P,A+1
00140 POPAJ: POP P,A
00150 POPJ P,
00160
00170 EFM: HLRZ T,(T)
00180 CALLF 1,(T)
00190 JRST EVAL
00200 PAGE
00010 APPLY: MOVEI TT,AP2 ;(THIS IS LISP APPLY)
00020 CAME T,[-3]
00030 JRST PDLARG
00040 MOVEM T,APFNG1#
00050 PUSHJ P,ALIST
00060 MOVE T,APFNG1
00070 JSP TT,PDLARG
00080 PUSH P,[UNBIND]
00090 AP2: PUSH P,A ;(THIS IS LISP *APPLY)
00100 MOVEI T,0
00110 AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
00120 HLRZ C,(B)
00130 PUSH P,C ;push arg
00140 HRRZ B,(B)
00150 SOJA T,AP3
00160
00170 IAP4: JUMPGE D,TOOFEW ;special case for fexprs
00180 AOJN R,TOOFEW
00190 HRRZ A,SP
00200 ADD A,SPNM ;*** MAKE IT A SPDL POINTER
00210 PUSH P,A
00220 MOVNI R,2
00230 SOJA T,IAP5
00240
00250 FUNCT: HLRZ B,(A)
00260 HRRZ A,SP
00270 ADD A,SPNM ;*** MAKE IT A SPDL POINTER
00280 PUSHJ P,XCONS
00290 MOVEI B,FUNARG(S)
00300 JRST XCONS
00310 PAGE
00010 APFNG: SOS T
00020 MOVEM T,APFNG1
00030 JSP TT,PDLARG ;get args and funarg list
00040 HRRZ A,(A)
00050 HRRZ D,(A) ;a-list pointer
00060 HLRZ A,(A) ;function
00070 HRLZ R,APFNG1 ;no. of args
00080 PUSH P,[UNBIND]
00090 JSP TT,ARGP1 ;replace args and fn name
00100 PUSH P,D ;a-list pointer
00110 PUSHJ P,ALIST ;set up spec pdl
00120 POP P,D
00130 AOS T,APFNG1
00140
00150 ;falls through
00160 PAGE
00010 ;falls in
00020
00030 IAPPLY: MOVE C,T ;state of world at entrance
00040 ADDI C,(P) ;t has - number of args on pdl
00050 ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
00060 JUMPE B,UNDTAC ;*** NIL NOT A FUNCTION
00070 CAILE B,INUMIN
00080 JRST UNDTAC
00090 CAMGE B,FSO ;WMT- CHECK FOR FUNCTION TO BE IN BPS
00100 JRST IAPBPS ;WMT- IT MAY BE 3/4/77
00110 HLRZ A,(B)
00120 CAIN A,-1
00130 JRST IAP1 ;fn is atomic
00140 CAIN A,LAMBDA(S)
00150 JRST IAPLMB
00160 CAIN A,FUNARG(S)
00170 JRST APFNG
00180 CAIN A,LABEL(S)
00190 JRST APLBL
00200 PUSH P,T
00210 MOVE A,B
00220 PUSHJ P,EVAL
00230 POP P,T
00240 MOVE C,T
00250 ADDI C,(P)
00260 ILP1B: MOVEM A,(C)
00270 JRST ILP1A
00280
00290 IAPXPR: HLRZ A,(B)
00300 JRST ILP1B
00310 IAP1: HRRZ B,(B)
00320 JUMPE B,IAP2
00330 HLRZ TT,(B)
00340 HRRZ B,(B)
00350 CAIN TT,EXPR(S)
00360 JRST IAPXPR
00370 CAIN TT,LSUBR(S)
00380 JRST IAP6
00390 CAIE TT,SUBR(S)
00400 JRST IAP1
00410 HLRZ B,(B)
00420 JUMPE B,UNDTAC ;*** DON'T ALLOW SUBR PROP. OF NIL
00430 IAP1A: MOVEM B,(C)
00440 JRST ESB1
00450
00460 IAPBPS: CAIGE B,FS ;WMT- IS IT REALLY IN BPS
00470 JRST UNDTAC ;WMT- NO
00480 JRST IAP1A ;WMT- YES, HANDLE LIKE SUBR 3/4/77
00490
00500 PAGE
00010 IAPLMB: HRRZ B,(B)
00020 HLRZ TT,(B)
00030 MOVEM SP,SPSV
00040 HRRZ B,(B)
00050 HLRZ D,(TT)
00060 CAIN D,-1
00070 JUMPN TT, IAP3
00080 MOVE R,T
00090 IPLMB1: JUMPE T,IPLMB2 ;no more args
00100 JUMPE TT,TOMANY ;too many args supplied
00110 IAP5: HLRZ A,(TT)
00120 MOVEI AR1,1(T)
00130 ADD AR1,P
00140 HLLZ D,(AR1)
00150 HRLM A,(AR1)
00160 HRRZ TT,(TT)
00170 AOJA T,IPLMB1
00180 PAGE
00010 IPLMB2: JUMPN TT,IAP4 ;too few args supplied
00020 JUMPE R,IAP69
00030 IPLMB4: POP P,AR1
00040 HLRZ A,AR1
00050 AOJG R,IPLMB3
00060 PUSHJ P,BIND
00070 JRST IPLMB4
00080 IPLMB3:
00090 IFN ALVINE,<
00100 SKIPE BACTRF ;*** ONLY IF ALVINING
00110 JRST [HRRI AR1,CPOPJ
00120 TLNE AR1,-1
00130 PUSH P,AR1
00140 JRST .+1]>
00150 MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
00160 PUSH SP,SPSV
00170 MOVE T,B ;$$SETUP FOR IMPLIED PROG
00180 PUSHJ P,COND2+1 ;$$INSTEAD OF EVAL
00190 JRST UNBIND
00200
00210 IAP69: POP P,(P)
00220 MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
00230 MOVE T,B ;$$
00240 JRST COND2+1 ;$$INSTEAD OF EVAL
00250
00260 IAP6: HLRZ B,(B)
00270 JUMPE B,UNDTAC ;*** DON'T ALLOW LSUBR PROP. OF NIL
00280 MOVEI TT,CPOPJ
00290 MOVEM TT,(C)
00300 JRST (B)
00310
00320 APLBL: MOVEM SP,SPSV
00330 HRRZ B,(B)
00340 HLRZ A,(B)
00350 HRRZ B,(B)
00360 HLRZ AR1,(B)
00370 MOVEM AR1,(C)
00380 PUSHJ P,BIND
00390 MOVEI A,APLBL1
00400 EXCH A,-1(C)
00410 EXCH A,LBLAD#
00420 HRLI A,LBLAD
00430 PUSH SP,A
00440 PUSH SP,SPSV
00450 JRST IAPPLY
00460 APLBL1: PUSH P,LBLAD
00470 JRST SPECSTR
00480
00490 IAP2: HRRZ A,(C)
00500 MOVEI B,VALUE(S)
00510 PUSHJ P,GET
00520 JUMPE A,UNDTAC
00530 HRRZ A,(A)
00540 HRRZ B,(C) ;$$GET ORIGINAL FN NAME
00550 CAME A,B ;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
00560 CAIN A,UNBOUND(S)
00570 JRST UNDTAC
00580 JRST ILP1B
00590
00600 IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
00610 MOVE A,TT
00620 PUSHJ P,BIND
00630 PUSH P,%ARG
00640 SUBI C,INUM0
00650 HRRM C,%ARG
00660 PUSH SP,SPSV
00670 MOVEI A,NIL ;$$ MORE FOR IMPLIED PROG
00680 MOVE T,B ;$$
00690 PUSHJ P,COND2+1 ;$$ INSTEAD OF EVAL
00700 HRRZ T,%ARG
00710 POP P,%ARG
00720 SUBI T,1-INUM0(P)
00730 HRLI T,-1(T)
00740 ADD P,T
00750 JRST UNBIND
00760
00770 ARG: HRRZ A,@%ARG
00780 POPJ P,
00790
00800 REMOTE<
00810 %ARG: XWD A,0>
00820 SETARG: HRRZM B,@%ARG
00830 JRST PROG2
00840 PAGE
00010 BIND: JUMPE A,BNDERR ;$$CAN'T REBIND NIL
00020 CAIE A,TRUTH(S) ;$$SHOULDN'T REBIND T
00030 CAILE A,INUMIN ;*** INUMS AREN'T NICE VARIABLES
00040 JRST BNDERR ;$$
00050 HLRE T,(A) ;*** NOR ARE NON-LITATOMS
00060 AOJN T,BNDERR ;***
00070 PUSH P,B
00080 HRRZM A,BIND3#
00090 BIND2:
00100 MOVEI B,VALUE(S) ;bind atom in a to value in ar1,save
00110 PUSHJ P,GET ;old binding on s pdl
00120 JUMPE A,BIND1 ;add value cell
00130 PUSH SP,(A)
00140 HRLM A,(SP)
00150
00160 HRRM AR1,(A) ;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
00170 SETZM BIND3 ;*** SO GC WON'T MARK GARBAGE
00180 POPBJ: POP P,B
00190 POPJ P,
00200
00210 BIND1:
00220 MOVEI B,UNBOUND(S)
00230
00240 MOVE A,BIND3 ;$$SET UP ATOM POINTER FROM SPECIAL CELL
00250 ;$$THIS WAS MOVEI A,0
00260 PUSHJ P,CONS
00270 HRRZ B,@BIND3
00280 PUSHJ P,CONS
00290 MOVEI B,VALUE(S)
00300 PUSHJ P,XCONS
00310 HRRM A,@BIND3
00320 MOVE A,BIND3
00330 JRST BIND2
00340
00350 UBD: CAMG SP,B
00360 POPJ P,
00370
00380 HLRZ TT,(SP) ;$$SKIP OVER EVAL BLIPS ETC.
00390 JUMPN TT,PJUBND ;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
00400 SUB SP,[XWD 2,2] ;$$DECREMENT SPDL
00410 JRST UBD ;$$GO BACK AND CHECK
00420 PJUBND: PUSHJ P,UNBIND
00430 JRST UBD
00440
00450 UNBIND:
00460 SPECSTR: MOVE TT,(SP)
00470 CAMN SP,SC2 ;$$CHECK TO AVOID OVERSHOOT
00480 POPJ P, ;$$
00490
00500 SUB SP,[XWD 1,1]
00510 JUMPGE TT,UNBIND ;syncronize stack
00520 UNBND1: CAMN SP,TT
00530 POPJ P,
00540 POP SP,T
00550
00560
00570 CAIN T,(T) ;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
00580 ;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
00590 JRST PROGUB ;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
00600
00610 MOVSS T
00620
00630 HLRM T,(T) ;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
00640
00650 JRST UNBND1
00660
00670
00680 PROGUB: HLRZ T,(T) ;$$CHECK FOR A PROG
00690 CAIE T,PROGAT+1(S) ;$$CHECK IF IT IS A PROG
00700 JRST PROGU1 ;$$NOT A PROG, SKIP IT AND GO ON
00710 MOVE T,(SP) ;$$GET THE RPDL POINTER FOR PROG INTO T
00720 ADDI T,2 ;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
00730 POP T,PA4 ;$$RESTORE PA4
00740 POP T,PA3 ;$$AND PA3 FROM WHERE THEY WERE SAVED
00750 PROGU1: POP SP,T ;$$ POP RPDL POINTER
00760 JRST UNBND1 ;$$AND GO ON WITH THE UNBINDING
00770
00780
00790
00800 SPECBIND: MOVE TT,SP
00810 SPEC1: LDB R,[POINT 13,(T),ACFLD]
00820 CAILE R,17
00830 JRST SPECX
00840 SKIPE R
00850 MOVE R,(R)
00860 HLL R,@(T) ;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
00870 EXCH R,@(T)
00880 HRLI R,@(T)
00890 PUSH SP,R
00900 AOJA T,SPEC1
00910 SPECX: PUSH SP,TT
00920 JRST (T)
00930
00940 ;random special case compiler run time routines
00950
00960 %AMAKE: HRRZ B,SP ;make alist for fsubr that requires it
00970 ADD B,SPNM ;*** MAKE IT A SPDL POINTER
00980 POPJ P,
00990
01000 %UDT: PUSHJ P,EPRNT1 ;error print for undefined computed go tag
01010 STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
01020 HRRZ R,(P)
01030 PUSHJ P,ERSUB3
01040 SETOM ERRTYP ;*** SET "SERIOUS" ERROR
01050 JRST ERREND
01060
01070 %LCALL: MOVN A,T ;set up routine for compile lsubr
01080 ADDI A,INUM0
01090 ADDI T,(P)
01100 PUSH P,T
01110 PUSHJ P,(3)
01120 POP P,T
01130 SUBI T,(P)
01140 HRLI T,-1(T)
01150 ADD P,T
01160 POPJ P,
01170 PAGE
00010 SUBTTL ARRAY SUBROUTINES
00020
00030 ;*** MODIFIED TO HANDLE CASE WHERE BPS EXTENDS BEYOND 177777
00040 ARRAY: PUSHJ P,ARRAYS
00050 HRRI AR2A,1(R)
00060 MOVE A,AR2A ; CUMULATED SIZE
00070 PUSH R,[0] ; FILL THEM ALL WITH NIL'S
00080 AOBJN A,.-1
00090 ARREND: MOVE A,BPPNR#
00100 MOVEM AR2A,-1(A)
00110 MOVEI A,1(R)
00120 PUSHJ P,FIX1A ;*** FIXED TO HANDLE NON-INUMS
00130 EXCH A,VBPORG(S) ;*** RETURN ADDRESS OF ARRAY
00140 POPJ P,
00150
00160 ARRAYS: PUSH P,A
00170 MOVE A,VBPORG(S)
00180 PUSHJ P,NUMVAL ;*** FIXED TO HANDLE NON-INUMS
00190 MOVEM A,BPPNR
00200 MOVE A,VBPEND(S)
00210 PUSHJ P,NUMVAL ;*** DITTO
00220 MOVNI A,-2(A)
00230 ADD A,BPPNR ;bporg-bpend+2
00240 HRLM A,BPPNR ;= BPORG-BPEND+2,,BPORG
00250 POP P,A
00260 HRRZ AR1,(A) ;(cdr l)
00270 HLRZ A,(A) ;(car l)name
00280 HRRZ B,BPPNR
00290 ADDI B,2
00300 MOVEI C,SUBR(S)
00310 PUSHJ P,PUTPROP ;(PUTPROP<NAME><BPORG>SUBR)
00320 HLRZ A,(AR1) ;(cadr l)mode
00330 PUSH P,AR1
00340 PUSHJ P,EVAL ;eval mode
00350 POP P,AR1
00360 MOVEM A,AMODE# ; STORE MODE AWAY
00370 MOVEI C,44 ; C IS BITS/ELEMENT
00380 JUMPE A,ARRY1 ; NIL=REAL NUMBERS MODE
00390 MOVEI C,-INUM0(A)
00400 CAILE A,INUMIN
00410 JRST ARRY1 ; NUMERIC MODE
00420 MOVEI C,22 ; NON-NUMERIC = T = S-EXPRS 2/WORD
00430 HRRZ A,BPPNR
00440 MOVE B,GCMKL
00450 PUSHJ P,CONS ; CONS BPORG ONTO GCMKL
00460 MOVEM A,GCMKL
00470 ARRY1: MOVEM C,BSIZE# ; NUMBER OF BITS/ELEMENT
00480 MOVEI A,44
00490 IDIV A,C
00500 MOVEM A,NBYTES# ; NUMBER OF ELEMENTS/WORD
00510 HRRZ A,(AR1) ;(cddr l)bound pair list
00520 JSP TT,ILIST ; PUTS REVERSE OF SIZES ONTO STACK,T=-# OF DIMS.
00530 AOS R,BPPNR ; R=BPORG-BPEND+2,,BPORG+1
00540 MOVEI AR1,1 ;ar1 is array size
00550 MOVEI AR2A,0 ;ar2a is cumulative residue
00560 AOJGE T,ARRYS ;single dimension
00570 MOVEI D,A-1
00580 SUB D,T ;d is next ARGUMENT ac for array code generation
00590 ARRY2: PUSHJ P,ARRB0 ;BUILDS IMULI (D),OFFSET/ ADD(D),(D)+1
00600 TLC TT,(IMULI)
00610 DPB D,[POINT 4,TT,ACFLD]
00620 PUSH R,TT
00630 CAIN D,A
00640 JRST ARRY3
00650 MOVSI TT,(ADD)
00660 ADDI TT,1(D)
00670 DPB D,[POINT 4,TT,ACFLD]
00680 PUSH R,TT
00690 SOJA D,ARRY2
00700
00710 ARRB0: POP P,TT ; REMOVE ELEMENT ON STACK BELOW EXIT
00720 EXCH TT,(P)
00730 CAILE TT,INUMIN ; IS IT A NUMBER
00740 JRST ARRB1 ; YES
00750 HLRZ A,(TT) ; NO, A DOTTED PAIR
00760 HRRZ TT,(TT)
00770 ; SUBI TT,(A)
00780 ; ADDI TT,1
00790 ; JRST ARRB2
00800 SKIPA TT,1(TT) ;WMT
00810
00820 ARRB1: MOVEI A,INUM0
00830 ; SUB TT,A
00840 SUBI TT,(A) ;WMT
00850 ;WMT- TT HAS THE LENGTH, A IS THE LOWER BOUND AS AN INUM
00860 IMUL A,AR1 ;WMT- WAS ARRB2:
00870 IMULB AR1,TT
00880 ;%% ADDM A,AR2A
00890 ADD AR2A,A ;%% SOME PEOPLE HAVE PROBLEMS
00900 POPJ P,
00910
00920 ARRY3: PUSH R,[ADD A,B]
00930 ARRYS: PUSHJ P,ARRB0
00940 HRRZ TT,BPPNR
00950 MOVEM AR2A,(TT)
00960 HRLI TT,(SUB A,)
00970 PUSH R,TT
00980 PUSH R,[JUMPL A,ARRERR]
00990 MOVE TT,AR1
01000 HRLI TT,(CAIL A,)
01010 PUSH R,TT
01020 PUSH R,[JRST ARRERR]
01030 IDIV AR1,NBYTES ;calc #words in array
01040 SKIPE AR2A ;correct for remainder non-zero
01050 ADDI AR1,1
01060 MOVE TT,NBYTES
01070 SOJE TT,ARRY6
01080 ADDI TT,1
01090 HRLI TT,(IDIVI A,)
01100 PUSH R,TT
01110 MOVN TT,BSIZE
01120 LSH TT,14
01130 HRLI TT,(IMULI B,)
01140 PUSH R,TT
01150 MOVEI TT,44+200
01160 SUB TT,BSIZE
01170 LSH TT,6
01180 ARRY6: ADD TT,BSIZE
01190 LSH TT,6
01200 SKIPE AR2A,AMODE
01210 CAIL AR2A,INUMIN
01220 ADDI TT,40 ;mode not = t
01230 TLC TT,(HRLZI C,)
01240 PUSH R,TT
01250 MOVEI TT,4(R)
01260 HRLI TT,(ADDI C,(A))
01270 PUSH R,TT
01280 PUSH R,[LDB A,C]
01290 HRLZI AR2A,(POPJ P,)
01300 SKIPN TT,AMODE
01310 MOVE AR2A,[JRST FLO1A]
01320 CAIL TT,INUMIN
01330 MOVE AR2A,[JRST FIX1A]
01340 PUSH R,AR2A
01350 MOVS AR2A,AR1
01360 MOVNS AR2A
01370 POPJ P,
01380
01390 PAGE
00010 ;*** MODIFIED TO HANDLE CASE WHEN BPS EXTENDS BEYOND 177777
00020 GTBLK: PUSH P,B ;*** SAVE GC FLAG
00030 MOVNI C,-INUM0(A) ;##COMPUTE NEGATIVE LENGTH
00040 MOVE A,VBPORG(S) ;## GET BPORG
00050 PUSHJ P,NUMVAL ;## CONVERT (*** FIXED FOR NON-INUMS)
00060 HRLM C,(A) ;## MOVE TO BPORG INFO FOR (GC)
00070 HRRM A,(A) ;##
00080 PUSH P,A ;*** SAVE ADDR OF BLOCK
00090 AOS R,(A) ;## ADD ONE TO INFO AND MOVE TO R
00100 SUBI R,1 ;## SET PUSH DOWN POINTER(ASSUME POINTER BLOCK)
00110 SKIPN -1(P) ;## IS IT A POINTER BLOCK? (***)
00120 SUBI R,1 ;## NO
00130 MOVE A,VBPEND(S) ;## GET BPEND
00140 PUSHJ P,NUMVAL ;## CONVERT (*** FIXED FOR NON-INUMS)
00150 MOVNS A ;*** CONVERT TO NEGATIVE
00160 ADD A,R ;## BPORG-BPEND +(0 OR 1) (***)
00170 HRLI R,(A) ;## MOVE TO R FOR TESTING FOR BPS EXCEEDED
00180 PUSH R,[0] ;## CLEAR THE SPACE, NOTE THAT IF IT IS NOT
00190 AOJN C,.-1 ;## WE WILL ALSO CLEAR THE INFO LOCATION
00200 HRRZI A,1(R) ;## COMPUTE NEW BPORG (***)
00210 PUSHJ P,FIX1A ;*** FIXED FOR NON-INUMS
00220 HRRM A,VBPORG(S)
00230 POP P,A ;*** GET ADDRESS OF BLOCK
00240 POP P,B ;*** GET GC FLAG
00250 CAIN B,0 ;## IF IT WAS NOT A POINTER BLOCK, DONE
00260 POPJ P,
00270 MOVE B,GCMKL ;## GET GC'S LIST
00280 PUSHJ P,CONS ;## CONS
00290 MOVEM A,GCMKL ;## SAVE IT
00300 HLRZ A,(A) ;GET THE OLD BPORG BACK
00310 AOJA A,.-5 ;## ADD ONE AND RETURN
00320
00330
00340 BLKLST: PUSH P,A ;## SAVE LIST
00350 CAIE B,0 ;## BLK LENGTH GIVEN
00360 SKIPA A,B ;## YES
00370 PUSHJ P,LENGTH ;## NO, USE LENGTH OF LIST
00380 MOVEI B,(A) ;## GET A POINTER BLOCK FROM GTBLK
00390 PUSHJ P,GTBLK
00400 POP P,B ;## GET LIST BACK
00410 PUSH P,A
00420 HRRZI R,-1(A) ;## SET UP PDL
00430 HLRE C,(R) ;## NEG LENGTH FROM GC INFO.
00440 BLKLS1: HRRI A,1(A) ;## BUMP A FOR CDR
00450
00460 IFN OLDNIL< ;## IF(CDR NIL)#NIL
00470 TRNE B,-1 ;## END OF LIST?
00480 SKIPA B,(B) ;## NO
00490 SETZ B, ;## YES, REST OF BLOCK IS NIL
00500 >
00510
00520 IFE OLDNIL<
00530 MOVE B,(B) ;## IF (CDR NIL )=NIL
00540 >
00550
00560 HLL A,B ;## GET (CAR LIST)
00570 PUSH R,A ;## AND STORE
00580 AOJL C,BLKLS1 ;## SEE IF DONE
00590 HLLZM A,(R) ;## SET (CDR (LAST BLOCK)) TO NIL
00600 JRST POPAJ ;## AND RETURN POINTER TO THE BLOCK
00610
00620
00630 EXARRAY: PUSH P,A
00640 HLRZ A,(A)
00650 PUSHJ P,GETSYM
00660 JUMPE A,POPAJ
00670 PUSHJ P,NUMVAL
00680 EXCH A,(P)
00690 PUSHJ P,ARRAYS
00700 POP P,A
00710 HRRM A,-2(R)
00720 HRR AR2A,A
00730 JRST ARREND
00740
00750 STORE: PUSH P,A
00760 PUSHJ P,CADR
00770 PUSHJ P,EVAL ;value to store
00780 EXCH A,(P)
00790 HLRZ A,(A)
00800 PUSHJ P,EVAL ;byte pointer returned in c
00810 POP P,A
00820 NSTR: PUSH P,A
00830 TLNE C,40
00840 PUSHJ P,NUMVAL ;numerical array
00850 DPB A,C
00860 JRST POPAJ
00870
00880 PAGE
00010 SUBTTL EXAMINE, DEPOSIT , ETC
00020
00030 BOOLE: MOVE TT,T
00040 ADDI TT,2(P)
00050 MOVE A,-1(TT)
00060 SUBI A,INUM0
00070 DPB A,[POINT 4,BOOLI,OPFLD-2]
00080 PUSHJ P,BOOLG
00090 MOVE C,A
00100 BOOLL: PUSHJ P,BOOLG
00110 XCT BOOLI
00120 REMOTE<
00130 BOOLI: CLEARB C,A>
00140 JRST BOOLL
00150
00160 BOOLG: CAIL TT,(P)
00170 JRST BOOL1
00180 MOVE A,(TT)
00190 PUSHJ P,NUMVAL
00200 AOJA TT,CPOPJ
00210
00220 BOOL1: HRLI T,-1(T)
00230 ADD P,T
00240 POP P,B
00250 JRST FIX1A
00260
00270 EXAMINE: PUSHJ P,NUMVAL
00280 MOVE A,(A)
00290 JRST FIX1A
00300
00310 DEPOSIT: MOVE C,B
00320 PUSHJ P,NUMVAL
00330 EXCH A,C
00340 PUSHJ P,NUMVAL
00350 MOVEM A,(C)
00360 JRST MAKNUM
00370
00380 LSH: MOVEI C,-INUM0(B)
00390 PUSHJ P,NUMVAL
00400 LSH A,(C)
00410 JRST FIX1A
00420
00430 PAGE
00010 SUBTTL GARBAGE COLLECTER
00020
00030 ;garbage collector
00040
00050 GC: MOVEI R,1 ;*** COPY NIL INTO ACS 1-10 SO GARBAGE
00060 BLT R,10 ;*** WON'T BE MARKED
00070 PUSHJ P,AGC
00080 JRST FALSE
00090
00100 AGC: SETOM GCFLAG ;SET GCFLAG INCASE OF USER CONTROL-C
00110 MOVEM R,RGC#
00120 GCPK1: PUSH P,PA3
00130 PUSH P,PA4
00140 IFE OLDNIL <PUSH P,NILHD ;*** FAKE ATOM HEADER OF NIL>
00150 PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
00160 PUSH P,MKNAM3
00170 PUSH P,GCMKL ;i/o channel input lists and arrays
00180 PUSH P,BIND3
00190 PUSH P,INITF
00200 PUSH P,INITF1 ;## INIT FILE LIST
00210 GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
00220 JRST GCP4
00230 REMOTE<
00240 GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
00250 GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
00260 GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
00270 MOVE A,C3GC
00280 GCP5: BLT A,X ;zero bit tables, .=top of bit tables
00290 JRST GCRET1>
00300 GCRET1: SKIPN GCGAGV
00310 JRST GCP5A
00320 SKIPN F
00330 STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
00340 SKIPN FF
00350 STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
00360
00370 GCP5A: MOVEI TT,1
00380 MOVEI A,0
00390 RUNTIM A, ;time
00400 MOVNS A
00410 ADDM A,GCTIM#
00420 MOVE C,GCP3# ;.=bottom of reg pdl
00430 GCP6B: MOVE S,P
00440 HLL C,P
00450 MOVEI B,0
00460 GC1: CAMN C,S
00470 POPJ P,
00480 HRRZ A,(C)
00490 GCPI: CAMGE A,GCP# ;.=bottom of bit tables
00500 REMOTE<
00510 GCPP1:
00520 XXX5: FS>
00530 CAMGE A,GCPP1
00540 JRST GCEND
00550 CAML A,GCP1# ;.=bottom of full word space (fws)
00560 JRST GCMFW
00570 MOVE F,(A)
00580 LSHC A,-5
00590 ROT B,5
00600 MOVE AR1,GCBT(B)
00610 TDOE AR1,@GCBTP2 ;bit tab- (fs←-5), .=magic number for sync
00620 JRST GCEND
00630 MOVEM AR1,@GCBTP1 ;bit tab- (fs←-5)
00640 PUSH P,F
00650 HLRZ A,F
00660 JRST GCPI
00670 REMOTE<
00680 GCBTP1: XWD A,0
00690 GCBTP2: XWD A,0
00700 GCMFWS: XWD A,0>
00710
00720 GCMFW: MOVEI AR1,@GCMFWS ;.=- bottom of fws
00730 IDIVI AR1,44
00740 MOVNS AR2A
00750 LSH AR2A,36
00760 ADD AR2A,C2GC
00770 DPB TT,AR2A
00780 GCEND: CAMN P,S
00790 AOJA C,GC1
00800 POP P,A
00810 HRRZS A
00820 JRST GCPI
00830 REMOTE<
00840 GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
00850 C2GC: XWD 430100+AR1,X ;.=bottom of fws bit table
00860 C3GC: 0> ;(bottom bit table)bottom bit table+1
00870 GCBT: XWD 400000,0
00880 ZZ==1B1
00890 XLIST
00900 REPEAT ↑D31,<ZZ
00910 ZZ==ZZ/2>
00920 LIST
00930 GCP6: HRRZ R,SC2
00940 GCP6C: CAILE R,(SP) ;mark sp (***Ch. from CAIL 4/24/77)
00950 JRST GCP6A
00960 PUSH P,(R)
00970 HRRZ C,P
00980 PUSHJ P,GCP6B
00990 SUB P,[XWD 1,1]
01000 AOJA R,GCP6C
01010
01020 GCP6A: HRRZ R,GCMKL ;mark arrays
01030 GCP6D: JUMPE R,GCSWP
01040 HLRZ A,(R)
01050 MOVE D,(A)
01060 GCP6E: PUSH P,(D)
01070 HRRZ C,P
01080 PUSH P,(D)
01090 MOVSS (P)
01100 PUSHJ P,GCP6B
01110 SUB P,[XWD 2,2]
01120 AOBJN D,GCP6E
01130 HRRZ R,(R)
01140 JRST GCP6D
01150
01160 GFSWPP:
01170 PHASE 0
01180 GFSP1==.
01190 JUMPL S,.+3
01200 HRRZM F,(R)
01210 HRRZ F,R
01220 ROT S,1
01230 AOBJN R,.-4
01240 MOVE S,(D)
01250 HRLI R,-40
01260 AOBJN D,GFSP1
01270
01280 LPROG==.
01290 JRST GFSPR
01300
01310 DEPHASE
01320 ;garbage collector sweep
01330
01340 GCSWP: MOVSI R,GFSWPP
01350 BLT R,LPROG
01360 MOVEI F,NIL ;will become movei f,-1
01370 MOVE D,C3GCS
01380 JRST XXX3
01390 REMOTE<
01400 XXX3: MOVEI R,FS ;$$ANOTHER FOOLIST REMNANT
01410 GCBTL1: HRLI R,X ;-(32-<fs&37>
01420 MOVE S,(D)
01430 GCBTL2: ROT S,X ;fs&37
01440 AOBJN D,GFSP1
01450 JRST GFSPR>
01460 GFSPR: MOVE A,C1GCS
01470 MOVE B,C2GCS
01480 PUSHJ P,GCS0
01490 MOVE B,FF ; GET POINTER TO FULL SPACE LIST
01500 PUSHJ P,CNTLST ; AND GO COUNT IT
01510 MOVEM A,LFWCNT ; SAVE COUNT FOR LATER
01520 AOS INSFUL ; ASSUME INSUFFICIENT FULL SPACE ERROR...
01530 CAMLE A,FULLIM ; COMPARE WITH MIN. THRESHOLD FOR FULL WORDS
01540 SETOM INSFUL ; CLEAR FLAG IF SUFFICIENT SPACE
01550 MOVE B,F ; GET POINTER TO FREE SPACE LIST
01560 PUSHJ P,CNTLST ; COUNT FREE SPACE
01570 AOS INSFRE ; ASSUME INSUFFICIENT FREE SPACE
01580 CAMLE A,FRELIM ; COMPARE WITH MIN. TRHESHOLD FOR FREE SPACE
01590 SETOM INSFRE ; CLEAR FLAG IS SUFFICIENT SPACE RECLAIMED
01600 MOVEM A,LFSCNT ; SAVE COUNT FOR LATER
01610 SKIPN GCGAGV ; GC GAG ON ?
01620 JRST GCSPI1 ; YES...DON'T GIVE RESULTS OF GC.
01630 MOVEI R,TTYO ; SET ADDRESS OF TTY OUTPUT ROUTINE
01640 PUSHJ P,PRINL1 ; GO PRINT LENGTH OF FREE SPACE LIST
01650 STRTIP [SIXBIT / FREE STG,!/]
01660 MOVE A,LFWCNT ; RESTORE COUNT OF FULL SPACE LIST
01670 MOVEI R,TTYO ; AND OUTPUT ROUTINE
01680 PUSHJ P,PRINL1 ; NOW PRINT OUT LENGTH OF FULL WORD LIST
01690 STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
01700 GCSPI1: HRLZ S,GCSP1# ;bottom of reg pdl+1
01710 BLT S,NACS+3 ;reload ac's
01720 SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
01730 MOVE R,RGC
01740 MOVEI A,0
01750 RUNTIM A, ;time
01760 ADDM A,GCTIM
01770 MOVE S,ATMOV ;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
01780 ;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
01790 SKIPE CCFLAG ;*** ↑C HIT WHILE GCING?
01800 PUSHJ P,GCINT ;*** YES: GO INTERRUPT
01810 SETZM GCFLAG ;CLEAR GCFLAG
01820 JUMPE F,[ERR3 [SIXBIT /NO FREE STG LEFT!/]]
01830 JUMPE FF,[ERR3 [SIXBIT /NO FW STG LEFT!/]]
01840 SKIPN INSFRE ; DID INSUFF. FREE SPACE FLAG JUST GET SET?
01850 ERR2 [SIXBIT /NOT ENOUGH FREE STG. LEFT!/]
01860 SKIPN INSFUL ; DID INSUFF. FULL SPACE FLAG JUST GET SET?
01870 ERR2 [SIXBIT /NOT ENOUGH FULL WORDS LEFT!/]
01880 POPJ P,
01890
01900 GCINT: POP P,CCFLAG ;*** ↑C - GET CONTINUE ADDR
01910 SETZM GCFLAG ;*** CLEAR GCFLAG
01920 JRST CCINT1 ;*** AND ENTER ↑C TRAP ROUTINE
01930
01940 ; [UT] ADDED CODE TO CHECK FOR INSUFFICIENT SPACE RECLAIMED BY GARBAGE
01950 ; COLLECTION, AND QUIT BEFORE RUNNING OUT COMPLETELY.
01960
01970 ; SWITCHES HAVE FOLLOWING SETTINGS:
01980 ; -1 => CLEAR
01990 ; 0 => JUST SET (GIVE MSG THIS TIME)
02000 ; >0 => PREVIOUSLY SET (NO MSG)
02010 REMOTE <
02020 INSFRE: EXP -1 ; FLAG TO INDICATE INSUFFICIENT FREE SPACE
02030 INSFUL: EXP -1> ; FLAG TO INDICATE INSUFFICIENT FULL SPACE
02040
02050 GCS0: MOVEI FF,0
02060 GCS1: ILDB C,B
02070 JUMPN C,GCS2
02080 HRRZM FF,(A)
02090 HRRZ FF,A
02100 GCS2: AOBJN A,GCS1
02110 POPJ P,
02120
02130 REMOTE<
02140 C1GCS: 0 ;(- length of fws) bottom of fws
02150 C2GCS: XWD 100,0 ;.=bottom of fws bit table
02160 C3GCS: 0 ;-n wds in bt,,bt
02170 >
02180 GCGAG: EXCH A,GCGAGV#
02190 POPJ P,
02200
02210 GCTIME: MOVE A,GCTIM
02220 JRST FIX1A
02230
02240 TIME: MOVEI A,0
02250 RUNTIM A,
02260 JRST FIX1A
02270
02280 DTIME: MSTIME A, ;*** TIME OF DAY
02290 JRST FIX1A
02300
02310 DODATE: DATE A, ;*** DATE IN FORM (MO DAY YEAR-1900)
02320 IDIVI A,↑D31
02330 MOVEI T,INUM0+1(B) ;day
02340 IDIVI A,↑D12
02350 MOVEI TT,INUM0+1(B) ;month
02360 ADDI A,INUM0+↑D64 ;year-1900
02370 PUSHJ P,NCONS
02380 MOVE B,T
02390 PUSHJ P,XCONS
02400 MOVE B,TT
02410 JRST XCONS
02420
02430 SPEAK: MOVE A,CONSVAL#
02440 JRST FIX1A
02450
02460 CNTLST: SETZ A, ; COUNT LENGTH OF LIST POINTED BY REG B.
02470 JUMPE B,CPOPJ ; LIST SHOULD END WITH NIL...BE CAREFUL!!
02480 HRRZ B,(B) ; LOOK AT NEXT ELEMENT OF LIST
02490 AOJA A,.-2 ; AND LOOK AT THAT
02500
02510 ; [UT] REVISED ROUTINES TO COUNT AVAILABLE FREE SPACE AND FULL SPACE
02520 ;
02530 FSCNT: TRZA B,-1 ; COUNT FREE SPACE (SET UP TO GET FS PTR)
02540 FWCNT: MOVEI B,1 ; COUNT FULL SPACE (SET UP TO GET FULL SP. PTR)
02550 MOVE B,F(B) ; GET ONE POINTER OR THE OTHER
02560 PUSHJ P,CNTLST ; COUNT LENGTH OF THAT LIST
02570 JRST FIX1A ; AND CONVERT IT TO A NUMBER
02580
02590 ; [UT] SET MINIMUM SPACE THRESHOLDS
02600 ;WMT- LIMIT SETTING CODE
02610 RPDLIM: PUSHJ P,SETLIM ; REG PDL LIMIT
02620 SPDLIM: PUSHJ P,SETLIM ; SPEC PDL LIMIT
02630 FSLIM: PUSHJ P,SETLIM ; FREE SPACE LIMIT
02640 FWLIM: PUSHJ P,SETLIM ; FULL SPACE LIMIT
02650 ; THOSE PUSHJ'S ARE JUST TO SAVE .+1, THERE WILL BE NO POPJ
02660 SETLIM: PUSHJ P,NUMVAL ; GO GET VALUE
02670 POP P,B ; GET BACK FLAGS,,ADDRESS
02680 SUBI B,SPDLIM ; COMPUTE INDEX
02690 EXCH A,REGLIM(B) ; HERE IS WHERE IT'S STORED
02700 JRST FIX1A ; GO MAKE A NUMBER OUT OF IT
02710
02720 REMOTE<
02730 REGLIM: DEC 100 ; REGULAR PUSH DOWN LIMIT
02740 SPELIM: DEC 100 ; SPECIAL PUSH DOWN LIMIT
02750 FRELIM: DEC 100 ; FREE LIST LIMIT
02760 FULLIM: DEC 20 ; FULL LIST LIMIT
02770 LFWCNT: Z ; LAST FREE WORD COUNT
02780 LFSCNT: Z> ; LAST FREE SPACE COUNT
02790
02800 GCWORDS:MOVE A,LFWCNT ;WMT-GET LAST FREE WORD COUNT
02810 PUSHJ P,FIX1A ;WMT-MAKE INTEGER
02820 PUSH P,A
02830 MOVE A,LFSCNT ;WMT-DO THE SAME FOR FREE SPACE COUNT
02840 PUSHJ P,FIX1A
02850 POP P,B
02860 JRST CONS ;WMT-RETURN (LFSCNT . LFWCNT)
02870
02880 PAGE
00010 SUBTTL SYMBOL TABLE ACCESSING ROUTINES
00020
00030
00040 R50MAK: PUSHJ P,PNAMUK
00050 PUSH C,[0]
00060 HRLI C,700
00070 HRRI C,(SP)
00080 MOVEI B,0
00090 MK3: ILDB A,C
00100 LDB A,R50FLD
00110 CAMGE B,[50*50*50*50*50]
00120 SKIPN A
00130 POPJ P,
00140 IMULI B,50
00150 ADD B,A
00160 JRST MK3
00170
00180
00190
00200 ;## NEW ROUTINES FOR CONVERTING SYMBOLS TO CONS CELL
00210
00220 SYMERR: MOVE A,B
00230 SYMER1: PUSHJ P,EPRINT ;## PRINT OFFENDER
00240 ERR2 [SIXBIT /NOT A CONS CELL !/]
00250 ;## **CAUSES ERROR IF NOT IN FREE STORAGE**
00260 RGTSYM: PUSHJ P,GETSYM
00270 JUMPE A,CPOPJ ;*** FORGET IT IF NOT THERE
00280 PUSHJ P,NUMVAL ;## CONVERT TO REAL ADDRESS
00290 ADDI A,(S) ;## ADD RELOCATION
00300 CAIL A,FS(S) ;## LESS THAN FS(S) IS NOT CONS CELL
00310 CAML A,FWSO ;## FS(S)<= A < FWSO IS A CONS CELL
00320 JRST SYMER1
00330 JRST FIX1A ;*** CONVERT BACK TO A NUMBER
00340
00350 GETSYM: PUSHJ P,R50MAK
00360 TLO B,040000 ;04 for globals
00370 MOVE C,.JBSYM
00380 MK7: CAMN B,(C)
00390 JRST MK10 ;found
00400 AOBJP C,.+2
00410 AOBJN C,MK7
00420 TLC B,140000 ;10 for locals
00430 TLNE B,100000
00440 JRST MK7-1
00450 JRST FALSE
00460
00470 MK10: MOVE A,1(C) ;value
00480 JRST FIX1A
00490
00500
00510 ;## ROUTINE TO STORE A CONS CELL SO THAT IT CAN BE
00520 ;## REFERENCED VIA ,CELL(S) I.E. THRU INDEX REG. S
00530 ;## ERROR IF NOT LEGITIMATE CONS CELL
00540 RPTSYM: CAIL B,FS(S) ;## FS(S) =< B <FWSO IS A LEGIT
00550 CAML B,FWSO ;## CONS CELL, ALL ELSE IS ERROR
00560 JRST SYMERR ;## ERROR
00570 SUBI B,(S) ;## STRIP OFF RELOCATION
00580
00590 PUTSYM: PUSH P,B
00600 PUSHJ P,R50MAK
00610 MOVE A,B
00620 TLO A,040000 ;make global
00630 SKIPL .JBSYM
00640 AOS .JBSYM ;increment initial symbol table pointer
00650 MOVN B,[XWD 2,2]
00660 ADDB B,.JBSYM
00670 MOVEM A,(B) ;name
00680 POP P,1(B) ;value
00690 JRST FALSE
00700
00710 PATCH: BLOCK 20
00720
00730 PAGE
00010 SUBTTL SPRINT -- THE PRETTY PRINTER
00020 IFN SPRNT,< ;*** REPLACED BY COMPILED CODE
00030
00040
00050 ;THIS IS THE NEW IMPROVED VERSION OF SPRINT
00060
00070 ; 0(P) = A
00080 ; -1(P) = B
00090 ; -2(P) = C
00100 ; -3(P) = M
00110 ; -4(P) = N
00120 ; -5(P) = X
00130
00140
00150 SPRINT: SUBI B,INUM0
00160 SPRNT2: PUSH P,A
00170 PUSH P,B
00180 SETZM M#
00190 SETZB B,CSW#
00200 MOVEM P,STP#
00210 PUSHJ P,DEPTH
00220 SKIPN B,M
00230 JRST .+6
00240 MOVE A,LINL
00250 SUB A,B
00260 SUB A,B
00270 IDIV A,B
00280 CAILE A,14
00290 MOVEI A,14
00300 MOVEM A,CUT#
00310 MOVE A,0(P)
00320 IDIV A,LINL
00330 CAIG B,0
00340 ADD B,LINL
00350 MOVEM B,0(P)
00360 MOVEI C,0
00370 JRST .+3
00380
00390 ISPRIN: PUSH P,A
00400 PUSH P,B
00410 PUSH P,C
00420 PUSH P,[0]
00430 PUSH P,[0]
00440 PUSH P,[0]
00450 MOVE A,B
00460 SUB B,LINL
00470 JUMPLE B,.+3
00480 MOVE A,B
00490 MOVEM A,-4(P)
00500 PUSHJ P,POS
00510 MOVE A,-5(P)
00520 PUSHJ P,PATOM
00530 JUMPN A,SPRN1
00540 MOVE B,LINL
00550 SUB B,-4(P)
00560 ADDI B,1
00570 MOVEM B,0(P)
00580 SUB B,-3(P)
00590 MOVE A,-5(P)
00600 PUSHJ P,FLATLE
00610 JUMPN A,SPRN1
00620 MOVEI A,50
00630 PUSHJ P,TYO
00640 AOS -4(P)
00650 SOS 0(P)
00660 PUSHJ P,SPRN94
00670 JUMPN A,SPRN13
00680 HLRZ A,@-5(P)
00690 CAIN A,LAMBDA(S)
00700 JRST LAM
00710 CAIN A,PROGAT+1(S)
00720 JRST PRG
00730 PUSHJ P,PATOM
00740 JUMPN A,SPRN3
00750 MOVE B,0(P)
00760 CAILE B,20
00770 MOVEI B,20
00780 HLRZ A,@-5(P)
00790 PUSHJ P,FLATLE
00800 JUMPE A,SPRN12
00810 MOVEM A,-1(P)
00820 SPRN4: HRRZ A,@-5(P)
00830 MOVEM A,-2(P)
00840 PUSHJ P,SPRN92
00850 JUMPN A,SPRN8
00860 MOVE B,-1(P)
00870 CAMG B,CUT
00880 JRST SPRN2
00890 SKIPE CSW
00900 JRST SPRN8
00910 MOVE A,0(P)
00920 SUB A,B
00930 SUBI A,1
00940 MOVEM A,-1(P)
00950 SPRN5: MOVE B,-1(P)
00960 HLRZ A,@-2(P)
00970 PUSHJ P,FLATLE
00980 JUMPE A,SPRN8
00990 HRRZ A,@-2(P)
01000 MOVEM A,-2(P)
01010 PUSHJ P,SPRN92
01020 JUMPE A,SPRN5
01030 HRRZ B,@-2(P)
01040 JUMPN B,.+3
01050 MOVE B,-1(P)
01060 SOJA B,SPRN7
01070 HRRZ A,@-2(P)
01080 PUSHJ P,FLATSI
01090 SUBI A,INUM0-4
01100 SUB A,-1(P)
01110 MOVN B,A∂
01120 SPRN7: SUB B,-3(P)
01130 HLRZ A,@-2(P)
01140 PUSHJ P,FLATLE
01150 JUMPN A,SPRN18
01160 SPRN8: PUSHJ P,SPRN98
01170 SPRN9: HRRZ A,@-5(P)
01180 MOVEM A,-5(P)
01190 CAMN A,-2(P)
01200 JRST SPRN11
01210 PUSHJ P,POS6
01220 PUSHJ P,SPRN99
01230 JRST SPRN9
01240 SPRN2: PUSHJ P,SPRN97
01250 MOVE A,-1(P)
01260 ADDI A,1
01270 ADDM A,-4(P)
01280 SPRN12: PUSHJ P,SPRN95
01290 SPRN23: HRRZ A,@-5(P)
01300 MOVEM A,-5(P)
01310 SPRN11: PUSHJ P,SPRN94
01320 JUMPE A,SPRN12
01330 SPRN13: HRRZ A,@-5(P)
01340 JUMPE A,.+4
01350 PUSHJ P,FLATSI
01360 SUBI A,INUM0-3
01370 ADDM A,-3(P)
01380 AOS -3(P)
01390 MOVE C,-3(P)
01400 PUSHJ P,SPRN96
01410 SPRN16: HRRZ A,@-5(P)
01420 JUMPE A,SPRN17
01430 MOVEI A,40
01440 PUSHJ P,TYO
01450 MOVEI A,56
01460 PUSHJ P,TYO
01470 MOVEI A,40
01480 PUSHJ P,TYO
01490 HRRZ A,@-5(P)
01500 PUSHJ P,PRIN1
01510 SPRN17: MOVEI A,51
01520 PUSHJ P,TYO
01530 JRST SPRN22
01540 SPRN18: PUSHJ P,SPRN98
01550 MOVEI A,40
01560 PUSHJ P,TYO
01570 MOVE A,LINL
01580 SUB A,CHCT
01590 ADDI A,1
01600 PUSHJ P,SPRN93
01610 JUMPN A,SPRN21
01620 SPRN19: PUSHJ P,SPRN99
01630 PUSHJ P,SPRN91
01640 JUMPN A,.+3
01650 PUSHJ P,POS6
01660 JRST SPRN19
01670 PUSHJ P,POS6
01680 SPRN21: PUSHJ P,SPRN99
01690 JRST SPRN16
01700 LAM: PUSHJ P,PRIN1
01710 HRRZ A,@-5(P)
01720 MOVEM A,-5(P)
01730 MOVE B,-4(P)
01740 MOVEM B,-1(P)
01750 HLRZ A,0(A)
01760 PUSHJ P,PATOM
01770 MOVEI B,6
01780 CAIE A,NIL
01790 ADDI B,1
01800 ADDM B,-4(P)
01810 PUSHJ P,SPRN94
01820 JUMPN A,SPRN13
01830 PUSHJ P,SPRN95
01840 MOVE B,-1(P)
01850 MOVEM B,-4(P)
01860 JRST SPRN23
01870 PRG: PUSHJ P,PRIN1
01880 MOVE A,-4(P)
01890 MOVEM A,-1(P)
01900 ADDI A,5
01910 PUSHJ P,SPRN93
01920 JUMPN A,SPRN13
01930 PUSHJ P,SPRN95
01940 MOVE A,0(P)
01950 SUBI A,5
01960 MOVEM A,-2(P)
01970 PRG1: PUSHJ P,SPRN91
01980 JUMPN A,PRG3
01990 HLRZ A,@-5(P)
02000 PUSHJ P,PATOM
02010 JUMPE A,PRG2
02020 MOVE A,-1(P)
02030 PUSHJ P,POS
02040 PUSHJ P,SPRN99
02050 JRST PRG1
02060 PRG2: MOVE A,CHCT
02070 CAMG A,-2(P)
02080 PUSHJ P,TERPRI
02090 PUSHJ P,SPRN95
02100 JRST PRG1
02110 PRG3: HLRZ A,@-5(P)
02120 PUSHJ P,PATOM
02130 JUMPE A,SPRN13
02140 MOVE B,-1(P)
02150 MOVEM B,-4(P)
02160 JRST SPRN13
02170 SPRN1: MOVE A,-5(P)
02180 PUSHJ P,PRIN1
02190 SPRN22: SUB P,[XWD 6,6]
02200 JRST FALSE
02210 SPRN3: PUSHJ P,SPRN99
02220 MOVE A,0(P)
02230 SUB A,CHCT
02240 MOVEM A,-1(P)
02250 CAIG A,24
02260 JRST SPRN4
02270 JRST SPRN23
02280 SPRN91: HRRZ A,@-6(P)
02290 MOVEM A,-6(P)
02300 SPRN92: HRRZ A,(A)
02310 JRST PATOM
02320 SPRN93: MOVEM A,-5(P)
02330 HRRZ A,@-6(P)
02340 MOVEM A,-6(P)
02350 SPRN94: HRRZ A,@-6(P)
02360 JRST PATOM
02370 SPRN95: MOVEI C,0
02380 SPRN96: MOVE B,-5(P)
02390 HLRZ A,@-6(P)
02400 JRST ISPRIN
02410 SPRN97: HLRZ A,@-6(P)
02420 PUSHJ P,PATOM
02430 JUMPN A,.+3
02440 HLRZ A,@-6(P)
02450 PUSHJ P,PRIN1
02460 HRRZ A,@-6(P)
02470 MOVEM A,-6(P)
02480 POPJ P,
02490 SPRN98: HLRZ A,@-6(P)
02500 PUSHJ P,PATOM
02510 JUMPN A,CPOPJ
02520 SPRN99: HLRZ A,@-6(P)
02530 JRST PRIN1
02540 > ;***
02550
02560 POS6: MOVE A,-5(P)
02570 POS: PUSH P,A
02580 PUSH P,[0]
02590 MOVE A,LINL
02600 SUB A,CHCT
02610 ADDI A,1
02620 PUSH P,A
02630 CAMN A,-2(P)
02640 JRST POS4
02650 CAMG A,-2(P)
02660 JRST .+4
02670 PUSHJ P,TERPRI
02680 MOVEI A,1
02690 MOVEM A,0(P)
02700 SUBI A,1
02710 LSH A,-3
02720 ADDI A,1
02730 LSH A,3
02740 ADDI A,1
02750 MOVEM A,-1(P)
02760 CAMLE A,-2(P)
02770 JRST POS3
02780 POS2: MOVEI A,11
02790 PUSHJ P,TYO
02800 MOVE A,-1(P)
02810 MOVEM A,0(P)
02820 ADDI A,10
02830 JRST POS2-3
02840 POS5: MOVEI A,40
02850 PUSHJ P,TYO
02860 POS3: AOS A,0(P)
02870 CAMG A,-2(P)
02880 JRST POS5
02890 POS4: SUB P,[XWD 3,3]
02900 POPJ P,
02910
02920 IFN SPRNT,< ;***
02930 FLATLE: JUMPLE B,ABORT+1
02940 SETZM M
02950 MOVEM B,N#
02960 MOVEM P,STP
02970 SCN: PUSH P,A
02980 PUSHJ P,PATOM
02990 JUMPN A,EXIT1-6
03000 NA: AOS A,M
03010 CAMLE A,N
03020 JRST ABORT
03030 HLRZ A,@0(P)
03040 PUSHJ P,SCN
03050 HRRZ A,@0(P)
03060 MOVEM A,0(P)
03070 JUMPN A,.+3
03080 AOS A,M
03090 JRST EXIT1-2
03100 MOVE A,0(P)
03110 PUSHJ P,PATOM
03120 JUMPE A,NA
03130 MOVEI A,4
03140 ADDB A,M
03150 CAMLE A,N
03160 JRST ABORT
03170 MOVE A,0(P)
03180 PUSHJ P,FLATSI
03190 SUBI A,INUM0
03200 ADDB A,M
03210 CAMLE A,N
03220 JRST ABORT
03230 EXIT1: SUB P,[XWD 1,1]
03240 POPJ P,
03250 ABORT: MOVE P,STP
03260 JRST FALSE
03270
03280 DEPTH: PUSH P,A
03290 PUSH P,B
03300 PUSHJ P,PATOM
03310 JUMPN A,D2
03320 AOS A,0(P)
03330 CAMLE A,LINL
03340 JRST OUT+1
03350 CAMLE A,M
03360 MOVEM A,M
03370 MOVE A,-1(P)
03380 PUSH P,A
03390 PUSH P,[0]
03400 D1: HLRZ A,@-3(P)
03410 MOVE B,-2(P)
03420 PUSHJ P,DEPTH
03430 HRRZ A,@-3(P)
03440 MOVEM A,-3(P)
03450 MOVE B,-1(P)
03460 SETCMB C,0(P)
03470 JUMPN C,.+3
03480 HRRZ B,0(B)
03490 MOVEM B,-1(P)
03500 CAMN A,B
03510 JRST OUT
03520 PUSHJ P,PATOM
03530 JUMPE A,D1
03540 SUB P,[XWD 2,2]
03550 D2: SUB P,[XWD 2,2]
03560 POPJ P,
03570 OUT: SETOM CSW
03580 MOVE P,STP
03590 JRST @1(P)
03600 > ;***
03610 ;
03620 ;
03630 ;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
03640 ;
03650 .TAB: PUSHJ P,NUMVAL
03660 PUSHJ P,POS ;LET POS IN SPRINT DO THE WORK
03670 JRST FALSE
03680
03690 PAGE
00010 SUBTTL ALVINE AND LOADER INTERFACES
00020
00030 ;interface to alvine
00040
00050 IFN ALVINE,<
00060 ED: MOVE 10,EDA
00070 JRST (10)
00080 PUSH P,A
00090 HRRZ A,CORUSE
00100 HRRM A,LST
00110 AOS A
00120 HRRM A,EDA#
00130
00140
00150 HRRM A,ED1 ;$$SAVE REENTRY TO EDITOR
00160 AOS ED1# ;$$
00170
00180 MOVSI A,(SIXBIT /ED/)
00190 SETZ D, ;THAT RELOCATION AGAIN - SEE BELOW
00200 PUSHJ P,SYSINI
00210 HRLM A,LST
00220 MOVNS A
00230 PUSHJ P,MORCOR
00240 PUSHJ P,SYSINP+1
00250 POP P,A
00260 JRST ED
00270 GRINDEF:PUSH P,A
00280 PUSHJ P,ED
00290 POP P,A
00300 JRST 2(10)>
00310
00320 EXCISE:
00330 IFN ALVINE<
00340 MOVEI A,ED+2
00350 HRRM A,EDA>
00360 MOVE A,JRELO
00370 SETZM LDFLG# ;initial loader symbol table flag
00380 CORE A,
00390 JRST .+1
00400 JSP R,IOBRST
00410 JRST TRUE
00420
00430 PAGE
00010 ; lisp loader interface
00020 ;*** MODIFIED TO HANDLE CASE WHERE BPS EXTENDS BEYOND 177777
00030 LOAD: MOVEM A,LDPAR#
00040 AOS A,CORUSE
00050 MOVEM A,OLDCU#
00060 SKIPN LDPAR
00070 JRST LOAD2
00080 MOVE A,VBPORG(S)
00090 PUSHJ P,NUMVAL ;*** FIXED FOR NON-INUM ADDRESSES
00100 LOAD2: MOVEM A,RVAL# ;final destination of loaded code
00110 MOVSI A,(SIXBIT /LOD/)
00120 SETZ D,
00130 PUSHJ P,SYSINI
00140 SUBI A,150 ;extra room for locations 0 to 137 and slop
00150 PUSH P,A
00160 MOVNS A ;length(loader)
00170 HRRZM A,LODSIZ#
00180 PUSHJ P,MORCOR ;expand core for loader
00190 MOVEM A,LOWLSP# ;location of blt'ed low lisp
00200 MOVN B,(P) ;length(loader)
00210 ADD B,A
00220 MOVEM B,HVAL# ;temporary destination of loaded code
00230 HRLI A,0
00240 MOVE D,A ;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
00250 BLT A,(B) ;blt up low lisp
00260 MOVEI A,CCBLKL(D) ;***
00270 HRRM A,.JBINT ;*** SET NEW ↑C TRAP BLOCK
00280 HLL A,NAME+3(D) ;-length(loader)
00290 HRRI A,137-1
00300 PUSHJ P,SYSINP
00310 SKIPE LDFLG(D)
00320 JRST LOAD3
00330 SETOM LDFLG(D)
00340 MOVSI A,(SIXBIT /SYM/)
00350 PUSHJ P,SYSINI
00360 MOVNS A ;length symbols
00370 PUSHJ P,MORCOR ;expand core for symbols
00380 SKIPGE B,.JBSYM
00390 SOS B ;if no symbol table, use original .JBsym
00400 HLRZ A,NAME+3(D) ;-length(symbols)
00410 ADDB A,B
00420 HLL A,NAME+3(D) ;symbol table iowd
00430 PUSHJ P,SYSINP
00440 HRRM B,.JBSYM
00450 HLLZ A,NAME+3(D)
00460 ADDM A,.JBSYM
00470 JRST .+2
00480 LOAD3: SOS .JBSYM ;want .JBsym to point one below 1st symbol
00490 MOVE 3,HVAL(D) ;h
00500 MOVE 5,RVAL(D) ;r
00510 MOVE 2,3
00520 SUB 2,5 ;x=h-r
00530 HRLI 5,12 ;(w)
00540 HRLI 2,11 ;(v)
00550 SETZB 1,4
00560 JSP 0,140 ;call the loader
00570 MOVEM 5,RLAST#(D) ;last location loaded(in final area)
00580 MOVE T,OLDCU(D)
00590 MOVE A,.JBSYM
00600 MOVEM A,.JBSYM(T)
00610 MOVE A,.JBREL
00620 MOVEM A,.JBREL(T) ;update .JBrel
00630 HRLZ 0,LOWLSP(D)
00640 SOS LODSIZ(D)
00650 AOBJN 0,.+1
00660 BLT 0,@LODSIZ(D) ;blt down low lisp
00670 MOVE 0,@LOWLSP ;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
00680 HRRZ D,RLAST
00690 MOVE C,RVAL
00700 HRL C,HVAL
00710 SKIPE LDPAR
00720 JRST BINLD
00730 MOVE B,RLAST ;new coruse
00740 LDRET2: BLT C,(D) ;blt down loaded code
00750 HRRZM B,CORUSE ;top of code loaded
00760 MOVEI D,1
00770 ANDCAM D,.JBSYM
00780 SUB B,.JBSYM ;length of free core
00790 ORCMI B,776000
00800 AOJGE B,STRT ;no contraction
00810 ADD B,.JBREL ;new top of core
00820 PUSHJ P,MOVDWN
00830 CORE B, ;contract core
00840 JRST .+1
00850 JRST STRT
00860
00870 BINLD: MOVE A,VBPEND(S)
00880 PUSHJ P,NUMVAL ;*** FIXED FOR NON-INUM ADDRESSES
00890 CAML D,A
00900 JRST [ SETOM BPSFLG ;bps exceeded
00910 JRST STRT]
00920 MOVE A,D
00930 PUSHJ P,FIX1A ;*** FIXED FOR NON-INUM ADDRESSES
00940 MOVEM A,VBPORG(S) ;updat bporg
00950 SOS B,OLDCU ;old top of core
00960 JRST LDRET2
00970
00980 CCLINT: HRRZ D,.JBINT ;*** ↑C HIT DURING LOAD
00990 SUBI D,CCBLKL ;*** COMPUTE OFFSET SINCE NOT RESTORED
01000 HRLZ 0,LOWLSP(D)
01010 SOS LODSIZ(D)
01020 SETZM CCBLKL+2(D)
01030 AOBJN 0,.+1
01040 BLT 0,@LODSIZ(D) ;*** NOTE THIS RESTORES NORMAL .JBINT
01050 MOVE 0,@LOWLSP
01060 SETZM LDFLG ;*** INDICATE SYMBOLS LOST
01070 CCSTRT: MOVEI A,STRT
01080 MOVEM A,CCFLAG ;*** SET TO RE-START
01090 JRST CCINT1 ;*** GO TO TRAP ROUTINE
01100
01110 REMOTE<
01120 CCBLKL: XWD 4,CCLINT ;*** LOADER ↑C INTERRUPT BLOCK
01130 XWD 0,2
01140 0
01150 X>
01160 PAGE
00010 SYSINI: MOVEM A,NAME+1(D)
00020 ;%% FOLLOWING IS OLD, NON-PATCHABLE CHANNEL OPEN
00030 COMMENT &
00040 IFN SYSPRG,< MOVE A,[XWD SYSPRG,SYSPN]
00050 MOVEM A,NAME+3(D)>
00060 IFE SYSPRG,< SETZM NAME+3(D)>
00070 INIT 17
00080 SYSDEV
00090 0
00100 JRST AIN.4+1
00110 & ;%% END OF OLD CODE
00120
00130 ;%% NEW PATCHABLE CODE (DEVICE NAME IN LOW SEGMENT)
00140 MOVE A,SYSIN1(D) ;%% PICK UP PPN
00150 REMOTE<
00160 SYSIN1: XWD SYSPRG,SYSPN ;%% KEEP IN LOW SEGMENT
00170 >
00180 MOVEM A,NAME+3(D) ;%% RESET VALUE HERE
00190 MOVEI A,17 ;%% SET DATA MODE
00200 MOVEM A,SYSIN0(D) ;%%
00210 OPEN 0,SYSIN0(D) ;%% OPEN CHANNEL 0 TO READ FILE
00220 JRST AIN.4+1 ;%% ERROR IN OPEN IF HERE
00230 REMOTE<
00240 SYSIN0: 17 ;%% DUMP MODE I/O
00250 SYSDEV ;%% MAY BE PATCHED
00260 ;%% NOTE THAT THIS MAY REMAIN "SYS"
00270 ;%% WHEN HGHDAT IS CHANGED TO
00280 ;%% SOMETHING ELSE
00290 0 ;%% NO BUFFERING
00300 >
00310 LOOKUP NAME(D)
00320 JRST AIN.7+1
00330 MOVE A,[IOWD 1,NAME+3] ;KLUDGE BECAUSE OF REG. D
00340 ADD A,D
00350 MOVEM A,INLOW(D)
00360 INPUT INLOW(D) ;INPUT SIZE OF FILE
00370 REMOTE<
00380 INLOW: IOWD 1,NAME+3
00390 0>
00400 HLRO A,NAME+3(D)
00410 POPJ P,
00420
00430 REMOTE<
00440 NAME: SYSNAM
00450 0
00460 0
00470 0>
00480
00490 SYSINP: MOVEM A,LST(D)
00500 INPUT LST(D)
00510 STATZ 740000
00520 ERR2 AIN.8
00530 RELEASE
00540 POPJ P,
00550
00560 REMOTE<
00570 LST: 0
00580 0>
00590 PAGE
00010 MOVDWN: HRLM B,.JBSA ;##SAVE NEW .JBSA
00020 HLRZ A,.JBSYM
00030 JUMPE A,MOVS1
00040 ADDI A,1(B)
00050 HRL A,.JBSYM
00060 HRRM A,.JBSYM
00070 BLT A,(B) ;downward blt
00080 POPJ P,
00090
00100 MOVSYM: MOVE B,.JBREL
00110 HRLM B,.JBSA
00120 HLRE A,.JBSYM
00130 JUMPE A,MOVS1
00140 ADDI B,1(A) ;new bottom of symbol table
00150 MOVNI A,1(A)
00160 ADD A,.JBSYM ;last loc of old symbol table
00170 HRRM B,.JBSYM
00180 PUSH P,C
00190 MOVE B,.JBREL ;last loc of new symbol table
00200 MOVE C,(A) ;simulated upward blt
00210 MOVEM C,(B)
00220 SUBI B,1
00230 ADDI A,-1 ;lf+1,rt-1
00240 JUMPL A,.-4
00250 POP P,C
00260 POPJ P,
00270
00280 MOVS1: HRRZM B,.JBSYM
00290 POPJ P,
00300
00310 ;enter with size needed in a
00320 ;exit with pointer in a to core
00330
00340 MORCOR: PUSH P,B
00350 HRRZ B,.JBSYM
00360 CAIL B,SHRST ;WMT- WHAT IF SYMBOLS IN HIGH SEG?
00370 MOVE B,.JBREL ;WMT- ACT LIKE THERE ARE NONE
00380 SUB B,CORUSE(D)
00390 SUBM A,B ;NEEDED-(.JBSYM-CORUSE) (IE. NEEDED-FREE)
00400 JUMPL B,EXPND2
00410 ADD B,.JBREL ;new core size
00420 CORE B, ;expand core
00430 ERR2 [SIXBIT /CANT EXPAND CORE !/]
00440 PUSH P,A
00450 HRRZ B,.JBSYM ;WMT
00460 CAIG B,SHRST ;WMT- DON'T MOVE SYMS IF IN HIGH SEG
00470 PUSHJ P,MOVSYM
00480 POP P,A
00490 EXPND2: MOVE B,CORUSE(D)
00500 ADDM A,CORUSE(D)
00510 MOVE A,B
00520 JRST POPBJ
00530 PAGE
00010 SUBTTL HIGH SEGMENT FUNCTIONS
00020
00030 HGHCOR: JUMPE A,NOWRT ;EXPAND CORE AND SET WRITE STATUS
00040 PUSHJ P,NUMVAL
00050 JUMPLE A,FALSE
00060 SETZ C,
00070 SETUWP C,
00080 UWPERR: ERR2 [SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
00090 SETZM WRTSTS ;*** MOVED TO AFTER SETUWP CHECK
00100 MOVE B,VHGHORG
00110 ADD B,A
00120 HRRZ C,.JBHRL
00130 CAMG B,C
00140 JRST TRUE
00150 HRLZ A,B
00160 CORE A,
00170 ERR2 [SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
00180 JRST TRUE
00190 NOWRT: MOVEI A,1
00200 MOVEM A,WRTSTS
00210 SETUWP A,
00220 JRST UWPERR
00230 JRST TRUE
00240
00250 HGHORG: SKIPE A ;SET HIGH ORG. TO A AND RETURN OLD ORG.
00260 PUSHJ P,NUMVAL
00270 PUSH P,A
00280 MOVE A,VHGHORG
00290 PUSHJ P,FIX1A ;WMT-
00300 POP P,B
00310 SKIPE B
00320 MOVEM B,VHGHORG
00330 POPJ P,
00340
00350 HGHEND: HRRZ A,.JBHRL ;GET VALUE OF END OF HIGH SEG.
00360 JRST FIX1A ;WMT
00370
00380 ;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
00390 SETSYS: MOVE T,A ;MOVE ARGUMENT FOR UIOSUB
00400 SETZM DEV ;## ALLOW DEFAULT TO DSK:
00410 PUSHJ P,IOSUB ;BREAKS DOWN THE SPECIFICATION
00420 MOVEM A,HGHDAT+1 ;SAVE THE FILE NAME
00430 MOVE A,DEV ;GET THE DEVICE AND SAVE IT
00440 MOVEM A,HGHDAT
00450 MOVE A,PPN ;GET THE PPN AND SAVE IT
00460 MOVEM A,HGHDAT+4
00470 JRST FALSE ;RETURN NIL
00480 REMOTE<
00490 WRTSTS: 1
00500 VHGHORG: BHORG>
00510 PAGE
00010 SUBTTL REALLOC CODE
00020
00030
00040 IFN REALLC <
00050 ;%% DYNAMIC REALLOCTION ROUTINE
00060 ;%%
00070 ;%% ARGUMENTS:
00080 ;%% A = FULL WORD SPACE INCREMENT
00090 ;%% B = BINARY PROGRAM SPACE INCREMENT
00100 ;%% C = REGULAR PUSHDOWN LIST INCREMENT
00110 ;%% AR1 = SPECIAL PUSHDOWN LIST INCREMENT
00120 ;%% AR2A = FREE SPACE INCREMENT
00130 ;%%
00140 ;%% ACTION:
00150 ;%% 1) PERFORMS AN EXCISE
00160 ;%% 2) ALLOCATES ADDITIONAL CORE AS REQUIRED
00170 ;%% (IF IMPOSSIBLE, SIGNALS "CAN'T EXPAND CORE")
00180 ;%% 5) UNBINDS ALL VARIABLES ON THE SPECIAL STACK
00190 ;%% AND CLEARS BOTH STACKS
00200 ;%% 4) REALLOCATES SPACE ACCORDING TO SPECIFICATIONS
00210 ;%% (NOTE THAT TOTAL CORE USED WILL BE ROUNDED
00220 ;%% UP TO A MULTIPLE OF 1K WORDS, AND ANY EXCESS
00230 ;%% WILL BE APPORTIONED TO FWS, RPDL, SPDL, AND
00240 ;%% FS.)
00250 ;%% 5) RESTARTS THE SYSTEM AT THE TOP LEVEL
00260 ;%%
00270
00280 REALL1: JUMPE A,.+2 ;%%NO CONVERSION IF NIL
00290 PUSHJ P,NUMVAL ;%%CONVERT TO BINARY
00300 ADDI T,(A) ;%%ADD TO TOTAL BEING ACCUMULATED
00310 EXCH A,(P) ;%%PUSH ON STACK
00320 JRST (A) ;%%AND RETURN
00330
00340 REALLOC:
00350 SETZ T, ;%% CLEAR ACCUMULATOR FOR ALLOC TOTAL
00360 MOVE TT,B ;%% SAVE SECOND ARG DURING FIRST CALL
00370 PUSHJ P,REALL1 ;%% PROCESS FIRST ARG
00380 MOVE A,TT ;%%
00390 PUSHJ P,REALL1 ;%% PROCESS SECOND ARG
00400 MOVE A,C ;%%
00410 PUSHJ P,REALL1 ;%% PROCESS THIRD ARG
00420 MOVE A,AR1 ;%%
00430 PUSHJ P,REALL1 ;%% PROCESS FOURTH ARG
00440 MOVE A,AR2A ;%%
00450 PUSHJ P,REALL1 ;%% PROCESS FIFTH ARG
00460 MOVE A,-4(P) ;%% PICK UP FWS INCREMENT
00470 ADD A,SFWS ;%% MAKE NEW TOTAL FWS
00480 IDIVI A,44 ;%% CALCULATE SPACE FOR BIT TABLE
00490 ADDI T,1(A) ;%% ADD TO TOTAL
00500 MOVEM T,(P) ;%% SAVE TOTAL (FS AMOUNT NOT NEEDED)
00510 PUSHJ P,EXCISE ;%% CLEAR BUFFERS, ETC.
00520 POP P,A ;%% GET TOTAL BACK
00530 SETZ D, ;%% CLEAR RELOCATION REGISTER
00540 ;%% (HERE WE GO AGAIN)
00550 PUSHJ P,MORCOR ;%% ALLOCATE THE ADDITIONAL SPACE
00560 MOVE B,SC2 ;%% CLEAR STACKS AND UNBIND VARIABLES
00570 PUSHJ P,UBD ;%%
00580 HRRZ B,.JBREL ;%% GET NEW HIGH LIMIT
00590 CAMGE B,JRELO# ;%% DID CORE GET SMALLER?
00600 HALT . ;%% YES -- WE QUIT
00610 MOVEM B,JRELO# ;%% RESET LIMIT
00620 HRLM B,.JBSA ;%%
00630 IFN ALVINE <
00640 MOVEI A,ED+2 ;%%INDICATE ED WAS OVERWRITTEN
00650 HRRM A,EDA ;%%SO THEY WILL BE RELOADED IF NEEDED
00660 >
00670 SETZM LDFLG ;%% INDICATE SYMBOLS GONE [1]
00680 MOVE A,SFWS ;%% SAVE OLD VALUE
00690 MOVEM A,OSFWS ;%%
00700 MOVE A,FSO ;%%
00710 MOVEM A,OFSO ;%%
00720 POP P,A ;%% SPDL INCREMENT
00730 ADDM A,SSPDL ;%% CHANGE TOTAL
00740 MOVN AR2A,A ;%% SAVE JUST IN CASE
00750 POP P,A ;%% RPDL INCREMENT
00760 ADDM A,SRPDL ;%% CHANGE TOTAL
00770 MOVN AR1,A ;%% SAVE AGAIN
00780 POP P,A ;%% BPS TOTAL
00790 MOVEM A,FSMOVE ;%% HOW MUCH TO MOVE FS
00800 ADDM A,FSO ;%% NEW FS ORIGIN
00810 ADDM A,SBPS ;%% BPS INCREMENT
00820 POP P,A ;%% FWS INCREMENT
00830 ADDM A,SFWS ;%% ADD TO TOTAL
00840 JRST REALL2 ;%% JUMP INTO REGULAR ALLOCATOR
00850 ;%% (ALL DATA OFF STACK)
00860 >
00870
00880 ALLOC: MOVE B,SC2 ;*** ACCUMS ARE OK IF HERE
00890 PUSHJ P,UBD ;*** SO UNBIND VARS FIRST
00900 INALLC: HRRZ A,.JBREL ;SEE IF CORE WAS EXPANDED
00910 CAMN A,JRELO# ;OR NOT
00920 JRST OUTALC ;NO EXPANSION - DON'T REALLOCATE
00930 CAMG A,JRELO# ;CHECK TO SEE IF IT GOT SMALLER!
00940 JRST [OUTSTR [ASCIZ /CORE SIZE HAS BEEN REDUCED - CANNOT RUN
00950 /]
00960 HALT .] ; BITCH ABOUT IT!
00970 MOVEM A,JRELO# ;SAVE NEW CORE BOUND
00980 HRLM A,.JBSA
00990 IFN ALVINE,<
01000 MOVEI F,ED+2 ;INDICATE THAT ED WAS OVERWRITTEN
01010 HRRM F,EDA ;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
01020 SETZM LDFLG ;%% INDICATE SYMBOLS GONE [1]
01030 INAGN: SETZM NOALIN# ;SET UP TO ASK FOR ALLOCATION
01040 OUTSTR [ASCIZ /
01050 ALLOC? (Y OR N) /] ;ASK USER IF HE WISHES TO SET UP
01060 INCHRW C ;THE ALLOCATION INCREMENTS
01070 CAIE C,"N" ;LOOK FOR N,n,Y,y
01080 CAIN C,"n"
01090 JRST NSTFWS ; DON'T ASK FOR INPUT
01100 CAIE C,"Y"
01110 CAIN C,"y"
01120 JRST SETFWS
01130 JRST INAGN ; NOT EXPECTED INPUT
01140 NSTFWS: SETOM NOALIN ; SET FLAG SO NO INPUT IS DONE LATER
01150 SETFWS: MOVE A,SFWS# ;SAVE OLD SIZE OF FWS
01160 MOVEM A,OSFWS#
01170
01180 SKIPN NOALIN ;SKIP QUESTIONS IF AUTOMATIC
01190 OUTSTR [ASCIZ /
01200 FULL WORD SP. = /]
01210 JSP R,ALLNUM
01220 JUMPN A,.+3
01230 SKIPE INITFW#
01240 ADDI A,440 ;INITIAL ALLOCATION FOR FWS
01250
01260 ADDM A,SFWS# ;ADD EITHER USER INCREMENT OR 0 TO SFWS
01270
01280 MOVE A,FSO# ;SAVE OLD FS ORIGIN
01290 MOVEM A,OFSO# ;FOR RELOCATION
01300
01310 SKIPN NOALIN ;SKIP IF USER DONE
01320 OUTSTR [ASCIZ /
01330 BIN. PROG. SP. = /]
01340 JSP R,ALLNUM
01350 JUMPN A,.+3
01360 SKIPE INITFW
01370 ADDI A,10 ;*** MAKE SURE THERE'S A LITTLE BPS
01380 ADDM A,SBPS#
01390 MOVEM A,FSMOVE# ;THE INCREMENT TO SBPS IS THE AMOUNT BY
01400 ADDM A,FSO# ;THE FREE SPACE IS MOVED - UPDATE ORIGIN
01410
01420 SKIPN NOALIN ;SKIPIF USER DONE
01430 OUTSTR [ASCIZ /
01440 REG. PDL. = /]
01450 JSP R,ALLNUM
01460 JUMPN A,.+3
01470 SKIPE INITFW# ;CHECK IF INITIAL ALLOCATION
01480 ADDI A,1000
01490 ADDM A,SRPDL#
01500 MOVN AR1,A ;SAVE IN CASE OF OVERFLOW
01510
01520 SKIPN NOALIN ;SKIP IF USER DONE
01530 OUTSTR [ASCIZ /
01540 SPEC. PDL. = /]
01550 JSP R,ALLNUM
01560 JUMPN A,.+3
01570 SKIPE INITFW# ;CHECK FOR INITIAL ALLOCATION
01580 ADDI A,1000
01590 ADDM A,SSPDL#
01600 MOVN AR2A,A ;SAVE IN CASE OF OVERFLOW
01610 IFN HASH,<
01620 SKIPN INITFW
01630 SETOM NOALIN
01640 SKIPN NOALIN
01650 OUTSTR [ASCIZ /
01660 HASH = /]
01670 JSP R,ALLNUM
01680 CAIG A,BCKETS
01690 JRST OCR
01700 HRRM A,INT1
01710 MOVNS A
01720 HRRM A,RH4
01730 SETOM HASHFG>
01740 REALL2: MOVE A,JRELO# ;COMPUTE SIZE OF AVAILABLE CORE
01750 SUBI A,FS ;SO THAT EXTRA CORE CAN BE DISTRIBUTED
01760
01770 SUB A,SBPS ;TAKE OFF CORE ALLOCATED FOR BPS
01780 SUB A,SFS# ;TAKE OFF CORE IN PREVIOUS FS
01790 SUB A,SBT# ;AND ASSOCIATED BIT TABLE
01800 SUB A,SFWS ;TAKE OFF CORE NOW ALLOCATED TO FWS
01810 SUB A,SRPDL ;TAKE OFF CORE NOW ALLOCATED TO RPDL
01820 SUB A,SSPDL ;TAKE OFF CORE NOW ALLOCATED TO SPDL
01830
01840 MOVE F,SFWS ;ESTIMATE SIZE NEEDED FOR BTF
01850 IDIVI F,44
01860 ADDI F,1
01870 SUB A,F ;AND TAKE IT OFF TOTAL
01880 MOVEM F,SBTF# ;ALSO SAVE TO RESTORE LATER
01890 JUMPGE A,ALOK ;MAKE SURE NO OVERFLOW
01900 OUTSTR [ASCIZ /ALLOCATIONS ARE TOO LARGE
01910 /] ; IF SO THEN RETRY
01920 MOVE A,OSFWS
01930 MOVEM A,SFWS ;RESTORE SIZE OF FWS
01940 MOVN A,FSMOVE
01950 ADDM A,SBPS ;RESET SIZE OF BPS
01960 ADDM A,FSO ;AND FS ORGIN
01970 ADDM AR1,SRPDL ;RESET STACKS
01980 ADDM AR2A,SSPDL
01990 CLRBFI ;*** CLEAR OUT ANY GARBAGE
02000 JRST INAGN
02010
02020 ALOK: MOVE B,A ;NOW CAN ALLOCATE EXCESS CORE
02030 ACHLOC: ASH B,-4 ;1/16 TO FWS
02040 ADDM B,SFWS
02050 SUB A,B ;TAKE IT OFF REMAINING CORE
02060 SKIPE INITFW
02070 SETZ B,
02080 ASH B,-4 ;1/64 TO PDLS
02090 ADDM B,SSPDL
02100 SUB A,B
02110 ADDM B,SRPDL
02120 SUB A,B ;AND TAKE IT OFF REMAINING CORE
02130
02140 MOVE T,SFWS ;CALCULATE ACTUAL SIZE OF BTF
02150 IDIVI T,44
02160 ADDI T,1
02170 ADD A,SBTF ;REMOVE ESTIMATED LOSS FOR BTF
02180 MOVEM T,SBTF
02190 SUB A,T ;AND TAKE OFF ACTUAL LOSS TO BTF
02200
02210 ADD A,SFS ;ADD BACK ON SPACE FROM OLD FS
02220 ADD A,SBT ;AND ASSOCIATED BT
02230 ;GIVING NEW SPACE AVAILABLE FOR
02240 ;FS AND BT
02250 MOVE TT,A
02260 IDIVI TT,41 ;SBS = SFS/32. = (SBS + SFS)/33.
02270
02280 ADDI TT,1
02290 MOVEM TT,SBT
02300
02310 SUB A,TT ;TAKE OFF SBT FROM REMAINING CORE
02320 MOVEM A,SFS ;GIVING AVAILABLE SFS
02330
02340 ;SET UP REGISTERS FOR GC ETC. SETUP
02350
02360 MOVE A,SFWS ;A ← SFWS
02370 MOVEI B,FS
02380 ADD B,SFS
02390 ADD B,SBPS ;B ← NFWSO (ORIGIN OF NEW FULL WORD SPACE)
02400 MOVE C,SRPDL ;C ← SRPDL
02410 MOVE F,OSFWS ;F ← OLD SIZE OF FWS
02420
02430 HRRM B,GCP1 ;GCP1 ← NFWSO
02440 MOVN SP,B ;-NEW BOTTOM OF FWS
02450
02460 HRRM SP,GCMFWS
02470 HRLZM A,C1GCS
02480 MOVNS C1GCS ;-NEW LENGTH OF FWS
02490 HRRM B,C1GCS ;HAVE FWS POINTER AND COUNT FOR SWEEP
02500
02510 ADD B,A ;NEW FIRST WORD OF BT (FS BIT TABLE)
02520
02530 MOVE SP,FSO ;SP ← NEW ORIGIN OF FS
02540
02550 LSH SP,-5
02560 SUBM B,SP ;NUMBER USED TO FIND BIT TABLE WORD
02570 HRRM SP,GCBTP1 ;FROM FS WORD ADDRESS
02580 HRRM SP,GCBTP2
02590
02600 HRLM B,C3GC ;BOTTOM OF BIT TABLES
02610 HRRM B,GCP2
02620 HRRM B,GCP ;(ALSO UPPER BOUND ON FWS AND FS)
02630
02640 MOVNI SP,-2(TT) ;-SIZE OF BT (TT = SBT)
02650 HRLM SP,C3GCS ;IOWD FOR BIT TABLE SWEEP
02660 HRRM B,C3GCS
02670 MOVE SP,FSO
02680 ANDI SP,37 ;MASK OUT ALL BU LAST FIVE BITS
02690 HRRM SP,GCBTL2 ;MAGIC NUMBER TO POSITION
02700 SUBI SP,40
02710 HRRM SP,GCBTL1
02720
02730 ADDI B,1 ;B ← B + 1
02740 HRRM B,C3GC ;BOTTOM OF FS BIT TABLE + 1
02750 ADDI B,-2(TT) ;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
02760 HRRM B,C2GCS ;BEFORE USE
02770
02780 ADDI B,1 ;B ← B + 1
02790 HRRM B,C2GC ;BOTTOM OF FWS BIT TABLE + 1
02800 ADDI B,-1(T) ;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
02810
02820 HRRM B,GCP5 ;TOP OF BIT TABLES
02830 ADDI B,1 ;BOTTOM OF REG PDL
02840
02850 MOVE S,ATMOV ;## S NOT SET IF LISP STARTED WITH CORE
02860 ;## ALREADY EXPANDED, SO RESET IT
02870 HRRZI A,OBTBL(S) ;GET OBLIST POINTER
02880 ;## RHX2 NO LONGER PURE, WE WANT THE SYSTEM OBLIST
02890 ;## THIS IS IT (I HOPE)3/28/73
02900 ADD A,FSMOVE ;INCREMENT TO
02910 ;ACCOUNT FOR MOVE OF FS
02920 MOVEM A,(B)
02930 HRRM B,GCP3 ;ROOM FOR ACS DURING GC
02940 ADDI B,1 ;B ← B + 1
02950 HRRM B,GCSP1
02960 HRRM B,GCP4 ;ROOM FOR ACS
02970 ADDI B,10 ;B ← B + 10
02980 HRRM B,GCP41 ;TOP OF AC AREA
02990 ADDI B,1 ;B ← B + 1
03000 HRRM B,C2 ;SET UP RPDL POINTER
03010 MOVNI A,-20(C) ;A ← - (C -20) = -(SRPDL - 20)
03020 HRLM A,C2 ;THIS IS THE ACTUAL SIZE OF RPDL
03030 ;TAKING INTO ACCOUNT THE AC AREA
03040
03050 HRRZ A,JRELO# ;TOP OF CORE - FOR SPDL PTR
03060
03070 MOVN B,SSPDL
03080 ADD A,B
03090 HRL A,B
03100
03110 MOVEM A,SC2# ;SET UP SPDL POINTER (I HOPE)
03120 MOVN A,A ;CREATE OFFSET FOR STACK POINTERS
03130 ADDI A,INUM0
03140 HRRZM A,SPNM#
03150 SETZM INITFW ;TURN OFF INITIAL ALLOCATION FLAG
03160
03170
03180
03190 ;RELOCATE THE FULL WORD SPACE
03200 ;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
03210 ;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
03220 ;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
03230
03240 MOVSI B,F
03250 HRR B,GCP1
03260 MOVE C,FWSO#
03270 HRRZI AR2A,-1(C) ;TAKE THE OPPORTUNITY TO GET ADDRESS
03280 ;OF END OF OLD FS (USED LATER)
03290 HRLI C,F
03300 MOVE A,@C ;GET WORD FROM END OF OLD FWS
03310 MOVEM A,@B ;AND MOVE TO END OF NEW FWS
03320 SOJGE F,.-2 ;F COUNTS DOWN WORDS IN OLDFWS
03330 ;END OF FWS RELOCATION
03340
03350 MOVE FF,FSMOVE ;GET FAST ACCESS TO RELOCATE SIZE FOR FS
03360 HRRZ F,AR2A
03370 ADD F,FF ;AND FIND WHERE TO PUT WORDS FROM
03380 ;END OF OLD FS IN NEW FS
03390
03400
03410 HRRZ AR1,GCP1 ;COMPUTE FWS RELOCATION CONSTANT
03420 SUB AR1,FWSO
03430
03440
03450 ;RELOCATE FS - ALSO RELOCATE ALL
03460 ;POINTERS TO FS AND TO FWS
03470
03480 REL1: HLRZ A,(AR2A) ;GET CAR POINTER OF OLD FS WORD
03490 JSP R,REL4
03500 HRLM A,(F) ;MOVE CAR TO NEW POSITION
03510 HRRZ A,(AR2A) ;GET CDR PTR
03520 JSP R,REL4 ;CHECK FOR FS RELOCATE
03530 HRRM A,(F)
03540 SUBI F,1 ;F ← F -1
03550 CAMLE AR2A,OFSO ;CHECK TO SEE IF DONE
03560 SOJA AR2A,REL1 ;NO - GO LOOP
03570 HRRZ A,GCMKL ;RELOCATE ARRAYS
03580 JSP R,REL4
03590 HRRZ D,A
03600 MOVEM D,GCMKL
03610 REL5: HLRZ AR2A,(D)
03620 MOVE AR2A,(AR2A)
03630 REL6: HLRZ A,(AR2A)
03640 JSP R,REL4
03650 HRLM A,(AR2A)
03660 HRRZ A,(AR2A)
03670 JSP R,REL4
03680 HRRM A,(AR2A)
03690 AOBJN AR2A,REL6
03700 HRRZ D,(D)
03710 JUMPN D,REL5
03720 SETZM BIND3 ;JUST IN CASE
03730 SKIPE INITF ;DON'T FORGET THE INITFN
03740 ADDM FF,INITF
03750 SKIPE INITF1 ;## DON'T FORGET THE INIT FILES
03760 ADDM FF,INITF1 ;##
03770 SKIPE NOUUOF ;RELOCATE FLAGS
03780 ADDM FF,NOUUOF
03790 IFN ALVINE<
03800 SKIPE BACTRF ;*** ONLY IF ALVINING
03810 ADDM FF,BACTRF>
03820 SKIPE GCGAGV
03830 ADDM FF,GCGAGV
03840 SKIPE RSTSW
03850 ADDM FF,RSTSW
03860 SKIPE DDTIFG ;*** RELOCATE DDT FLAG
03870 ADDM FF,DDTIFG ;***
03880 ; JRST RELFOO ;WMT
03890 RELFOO: MOVE S,SBPS ;S IS THE RELOCATOR FOR MOST MACRO
03900 MOVEM S,ATMOV ;REFERENCES TO ATOMS AND FS
03910 MOVE A,FSMOVE
03920 IFE OLDNIL< ADDM A,NILHD> ;## RESET NIL HEAD
03930 HRR B,VOBLIST(S) ;## GET CURRENT VALUE OF OBLIST
03940 HRRM B,RHX5 ;## RESET WORD THAT POSTINDEXES OFF B
03950 HRRM B,RHX2 ;## RESET WORD POSTINDEXING OFF C
03960 ADDM A,XXX3 ;## RESET WIERD CODE
03970 ADDM A,XXX4 ;## RESET UNBOUND
03980 ADDM A,XXX5 ;## RESET FS (SAME WORD AS FS),ALSO GCPP1
03990 MOVE A,GCP1
04000 HRRZM A,FWSO
04010 MOVE A,C3GCS
04020 HRRZM A,EFWSO#
04030 SETZB F,FF ;*** CLEAR F TO FORCE GC
04040 MOVE SP,SC2 ;*** INIT SPDL POINTER FOR UBD IN STRT
04050 MOVE P,C2 ;*** INIT PDL POINTER
04060 MOVE A,VBPEND(S) ;*** GET OLD BPEND
04070 PUSHJ P,NUMVAL ;*** (FIXED FOR POSSIBLE NON-INUM)
04080 ADD A,FSMOVE ;*** INCREMENT IT
04090 PUSHJ P,FIX1A ;*** CONVERT IT BACK (CAN CAUSE GC)
04100 MOVEM A,VBPEND(S) ;*** AND STORE IT
04110 OUTALC: JSP R,IOBRST
04120 JRST STRT
04130
04140 REL4: CAMGE A,EFWSO ;SEE IF BEYOND END OF FWS
04150 CAMGE A,OFSO ;OK - SEE IF MAYBE IN FS
04160 JRST (R)
04170 CAMGE A,FWSO ;SEE IF IN FWS
04180 JRST .+3
04190 ADD A,AR1 ;RELOCATE FWS POINTER
04200 JRST (R)
04210 ADD A,FF ;RELOCATE FS POINTER
04220 JRST (R)
04230
04240
04250 PAGE
00010 ;SUBROUTINE FOR NUMBER INPUT
00020 ;%% RETURNS 0 IF NOALIN # 0
00030 ;%% SETS NOALIN # 0 IF ALTMOD IS INPUT
00040 ;%% RETURNS 0 IF A BLANK IS INPUT
00050 ;%% IGNORES OTHER NON-NUMERIC CHARACTERS EXCEPT
00060 ;%% AS TERMINATORS OF NUMBERS
00070
00080 BANGCK: CAIN C,15 ;%% TERMINATE ON CR OR
00090 INCHRW C ;WMT-EAT LF AFTER CR
00100 CAIE C,12 ;WMT-TERMINATE ON LF
00110 CAIN C,40 ;%% TERMINATE ON BLANK
00120 JRST (R) ;%%
00130 CAIN C,ALTMOD ;%% ALTMODE (TERMINATOR)?
00140 JRST [SETOM NOALIN#
00150 JRST (R) ] ;%% YES--TURN ON SWITCH AND RETURN
00160 OUTSTR [ASCIZ/XXX /] ;WMT-ANY GARBAGE CAUSES RESTART
00170 ; JRST ALLNUM ;WMT-START OVER
00180
00190
00200 ALLNUM: SETZ A, ;%% CLEAR A
00210 SKIPE NOALIN#
00220 JRST (R)
00230 INCHRW C
00240 CAIL C,"0"
00250 CAILE C,"7"
00260 JRST BANGCK
00270 ASH A,3
00280 ADDI A,-"0"(C)
00290 JRST ALLNUM+3
00300
00310
00320 PAGE
00010 IFN HASH,<
00020 REHASH:
00030 MOVEI A,BFWS(S)
00040 PUSH P,A
00050 HRRM A,RHX2
00060 HRRM A,RHX5
00070 MOVS B,RH4#
00080 ADD B,S ;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
00090 ;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
00100 ;$$IN THE NEXT THREE FOO'S
00110
00120 HRRZI A,BFWS+1(B)
00130 MOVEM A,BFWS(B)
00140 AOBJN B,.-2
00150 SETZM BFWS(B)
00160 MOVSI AR2A,-BCKETS
00170 HRR AR2A,S ;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
00180 ;$$DOUBLE INDEXING WITH S IN REMOVING FOO
00190 ;$$PROBLEM
00200 RH1:
00210 HLRZ C,OBTBL(AR2A)
00220 RH3: JUMPE C,RH2
00230 HLRZ A,(C)
00240 PUSH P,C
00250 PUSH P,AR2A
00260 PUSHJ P,INTERN
00270 POP P,AR2A
00280 POP P,C
00290 HRRZ C,(C)
00300 JRST RH3
00310 RH2: AOBJN AR2A,RH1
00320 SETZM HASHFG
00330 POP P,A
00340 HRRM A,@GCP3
00350 MOVEM A,OBLIST(S)
00360 JRST STRT>
00370
00380 PAGE
00010 SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
00020
00030 ;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
00040 SPDLPT: HRRZ A,SP ;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
00050 ADD A,SPNM
00060 POPJ P, ;$$
00070
00080
00090 ;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
00100 SPDLFT: SUB A,SPNM ;$$CONVERT TO ADDRESS
00110 HLRE A,(A) ;$$GET LEFT HAND ITEM
00120 JUMPL A,TRUE ;$$IF IT IS NEGATIVE IT CAME FROM A STACK
00130 ;$$POINTER AND WE RETURN T INSTEAD
00140 HRRZI A,(A) ;$$CLEAR OUT LEFT HAND OF AC
00150 POPJ P, ;$$RETURN - RETURNS NIL FOR LHS = 0
00160
00170 ;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
00180 SPDLRT: SUB A,SPNM ;$$CONVERT TO AN ADDRESS
00190 HRRZ A,(A) ;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
00200 POPJ P, ;$$
00210
00220 ;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
00230 NEXTEV: SUB A,SPNM ;$$GET POINTER INSTEAD OF INUM
00240 HRRZ T,SC2 ;$$GET POINTER TO BOTTOM OF SPDL
00250
00260 SPDNLP: CAMG A,T ;$$CHECK IF HIT THE BOTTOM OF SPDL
00270 JRST FALSE ;$$RETURN NIL IF NO MORE INTERESTING WORDS
00280 HLL A,(A) ;$$TEST FOR WORD WITH 0 LHS
00290 TLZE A,-1 ;$$
00300 SOJA A,SPDNLP ;$$NOT AN INTERESTING WORD, LOOK AGAIN
00310 ADD A,SPNM ;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
00320 POPJ P, ;$$
00330
00340
00350 ;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
00360 ;$$ MORE EFFICIENT THAN EVAL WITH ALIST
00370 EVALV: MOVE C,A ;$$ MOVE AROUND FOR ATOM CHECK
00380 PUSHJ P,ATOM ;$$
00390 EXCH A,C ;$$
00400 SUB B,SPNM ;$$
00410 EVALV1: CAIL B,(SP) ;$$CHECK FOR END OF SPDL (*** CH FRM CAIN)
00420 JRST GETV ;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
00430 SKIPGE ,(B) ;$$CHECK TO AVOID SPDL POINTERS ON STACK
00440 AOJA B,EVALV1 ;$$
00450 HLRZ T,(B) ;$$T←CAR(B)
00460 SKIPE C ;$$
00470 HLRZ T,(T) ;$$GET CAR OF SPECIAL CELL - ATOM POINTER
00480 CAIE T,(A) ;$$COMPARE WITH ATOM TO BE EVALUATED
00490 AOJA B,EVALV1 ;$$NOT IT, LOOK SOME MORE
00500 HRRZ A,(B) ;$$GET VALUE FROM SPDL
00510 POPJ P, ;$$
00520
00530 GETV: JUMPE C,CDR
00540 MOVEI B,VALUE(S) ;$$ATOM NOT REBOUND, VALUE THEN IS
00550 PUSHJ P,GET ;$$
00560 JUMPE A,UNBOND ;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
00570 JRST CDR ;$$GET CDR OF SPECIAL CELL
00580
00590 UNBOND: HRRZI A,UNBOUND(S) ;$$RETURN ATOM UNBOUND
00600 POPJ P, ;$$
00610
00620 ;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
00630 CLRSPD: MOVEI B,-2-INUM0(A) ;$$ -2 TO GET OVER EVAL BLIP
00640 HLRZ TT,SC2# ;$$GET REAL SPD POINTER WITH A LHS
00650 ADD TT,B ;$$FIND OUT HOW MANY WORDS ARE USED
00660 ADD B,SC2 ;$$
00670 HRL B,TT ;$$SET UP SPD POINTER
00680 JRST UBD ;$$UBD DOES ALL THE WORK
00690
00700 ;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
00710 ;$$EVAL BLIP, WITH A GIVEN VALUE
00720 OUTVAL: PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL BLIP
00730 JUMPE A,FALSE ;$$ NO EVAL BLIP, RETURN NIL
00740 HRLZI C,(POPJ P,) ;$$ SET TYPE OF RETURN
00750 JRST SPRE1 ;$$ FINISH UP IN SPREDO
00760
00770
00780 ;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
00790 ;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
00800 REVAL1: HRRZ P,1(SP) ;$$ RPDL POINTER IS UP ONE
00810 HRRZ T,C2# ;$$
00820 HLRZ TT,C2# ;$$
00830 ADD TT,P ;$$
00840 SUB TT,T ;$$
00850 HRL P,TT ;$$
00860 DOSET: MOVE D,ERRTN ;$$ POP ERRSETS, LOAD CURRENT ERRSET
00870 SKIPE D ;$$DONE IF EMPTY
00880 CAMG D,P ;$$ COMPARE TO CURRENT RPDL
00890 XCT C ;$$ DONE, DO A STRANGE EXIT
00900 SUB D,[XWD 1,1] ;$$ GO DOWN A WORD
00910 POP D,ERRSW ;$$
00920 POP D,ERRTN ;$$
00930 JRST DOSET ;$$ TRY AGAIN
00940
00950
00960
00970 ;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
00980 ;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
00990
01000 SPREDO: PUSHJ P,NEXTEV ;$$FORCE TO EVAL BLIP POINTER
01010 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL BLIP
01020 MOVE B,A ;$$GET THE EXPRESSION
01030 SUB B,SPNM
01040 HRRZ B,(B)
01050 MOVE C,[JRST XXEVAL] ;$$SET RETURN (***Ch. from EVAL 4/24/77)
01060 SPRE1: PUSH P,B ;$$SAVE SPDL POINTER
01070 PUSHJ P,CLRSPD ;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
01080 POP P,A ;$$
01090 JRST REVAL1
01100
01110 ;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
01120 ;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
01130 ;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
01140 ;
01150 SPREVAL:PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL-BLIP
01160 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL-BLIP
01170 JRST SPRE1-1 ;$$LET SPREDO FINISH UP
01180
01190
01200 ;$$COMPUTES A LISP POINTER TO A STACK ENTRY
01210 STKPTR: SUB A,SPNM
01220 POPJ P,
01230
01240 PAGE
00010 SUBTTL LOW SEGMENT INCLUDING REMOTE CODE
00020 XALL
00030 RELOC ;WMT- WAS RELOC 0
00040 HERE
00050 VAR
00060 PAGE
00010 SUBTTL LISP ATOMS AND OBLIST
00020 FS:
00030
00040 DEFINE MAKBUC (A,%B)
00050 <DEFINE OBT'A <%B=.>
00060 XWD %B,IFN <<BCKETS-1>-A>,<.+1>
00070 IF1 <%B=0>>
00080
00090 DEFINE ADDOB (A,C,%B)
00100 <OBT'A
00110 DEFINE OBT'A<%B=.>
00120 IF1 <%B=0>
00130 XWD C,%B>
00140
00150 DEFINE PUTOB (A,B)
00160 <ZZ==<ASCII +A+>←<-1>
00170 ZZ==-ZZ/BCKETS*BCKETS+ZZ
00180 ADDOB \ZZ,B>
00190
00200 DEFINE PSTRCT (A)
00210 <ZZ==[ASCII +A+]
00220 LENGTH(ZY,<A>)
00230 ZY==<ZY-1>/5
00240 Q1(ZY,ZZ)
00250 >
00260
00270 DEFINE Q1 (N,Z)<
00280 IFN N,<XWD Z,[Q1(N-1,Z+1)]>
00290 IFE N,<XWD Z,0>>
00300
00310
00320 ;## ARGS ARE A=NAME, B=PROP NAME, C'A=THE PROPERTY, D=LABEL OF ATOM
00330
00340 DEFINE MKAT (A,B,C,D)
00350 <XLIST
00360 IRP A< PUTOB A,.+1
00370 D XWD -1,.+1
00380 XWD B,.+1
00390 XWD C'A,.+1
00400 XWD PNAME,.+1
00410 XWD [PSTRCT(A)],0>
00420 LIST>
00430
00440 ;## ARGS ARE: D'A=PROPERTY, B=PROP NAME, C=NAME
00450
00460 DEFINE MKAT1 (A,B,C,D)
00470 <XLIST
00480 IRP C <PUTOB C,.+1
00490 XWD -1,.+1
00500 XWD B,.+1
00510 XWD D'A,.+1
00520 XWD PNAME,.+1
00530 XWD [PSTRCT(C)],0>
00540 LIST>
00550
00560 DEFINE LENGTH (A,B)
00570 <A==0
00580 IRPC B,<A==A+1>>
00590
00600 ;## ATOM WITH SYM PROPERTY =V'ATOM LOCATION
00610 DEFINE ML1 (A)<IRP A,<
00620 V'A: XWD -1,.+1
00630 XWD FIXNUM,[A]
00640 MKAT A,SYM,V
00650 >>
00660
00670 ;## SIMILAR TO ML1, EXCEPT %C=THE SYM PROP
00680
00690 DEFINE MKSY1 (A,B,%C)<
00700 XLIST
00710 %C: XWD -1,.+1
00720 XWD FIXNUM,[A]
00730 PUTOB B,.+1
00740 XWD -1,.+1
00750 XWD SYM,.+1
00760 XWD %C,.+1
00770 XWD PNAME,.+1
00780 XWD [PSTRCT(B)],0
00790 LIST>
00800
00810 ;## ATOM WITH NO PROPS WITH LABEL SAME AS ATOM NAME
00820
00830 DEFINE ML (A)<
00840 XLIST
00850 IRP A,<PUTOB A,.+1
00860 A: XWD -1,.+1
00870 XWD PNAME,.+1
00880 XWD [PSTRCT(A)],0>
00890 LIST>
00900 ;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM
00910
00920 DEFINE MK (A)<
00930 XLIST
00940 IRP A,<PUTOB A,.+1
00950 XWD -1,.+1
00960 XWD PNAME,.+1
00970 XWD [PSTRCT(A)],0>
00980 LIST>
00990
01000 OBTBL:
01010 OBLIST: ZZ==0
01020 XLIST
01030 REPEAT BCKETS,<MAKBUC \ZZ
01040 ZZ==ZZ+1>
01050 LIST
01060
01070 PAGE
00010 ;## GENERATE # FNS ONLY IF NONUSEFUL VALUES DESIRED
00020 IFN NONUSE<
00030 MKAT1 MEMBR.,SUBR,MEMBER#
00040 MKAT1 MEMB,SUBR,MEMQ#
00050 MKAT1 AND.,FSUBR,AND#
00060 MKAT1 OR.,FSUBR,OR#
00070 >
00080 MKAT<RPLACA,RPLACD,MINUS,TERPRI,CAR,CDR,CAAR>,SUBR
00090 MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
00100 MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
00110 MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
00120 MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
00130 MKAT<GCGAG,CCON,CHRCT,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
00140 MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
00150 MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
00160 MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,MEMQ>,SUBR
00170 MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
00180 MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
00190 MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
00200 MKAT<PROG1,LITATOM,NTHCHAR>,SUBR
00210 IFN SPRNT,<MKAT<SPRINT>,SUBR>;***
00220 IFN STPGAP,<MKAT<PGLINE>,SUBR>
00230 IFN RANDOM,< ;WMT
00240 MKAT1 GTOPOS,SUBR,UGETO
00250 MKAT1 GTIPOS,SUBR,UGETI
00260 MKAT1 SETPOS,SUBR,USETI
00270 >
00280
00290 MKAT EXPLODEC,SUBR,%
00300 MKAT TAB,SUBR,.
00310 MKAT TYO,SUBR,I
00320 MKAT TYI,SUBR,I
00330 CEVAL=.+1
00340 MKAT1 EVAL,SUBR,*EVAL
00350
00360 ;$$ REDEF. FOR NEW MAP FUNCTIONS
00370 MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
00380 ;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
00390 MKAT1 MAPCAN,LSUBR,MAPCONC
00400
00410 PROGAT: MKAT<PROG>,FSUBR
00420
00430 ;##LIST STARTS HERE
00440 MKAT LIST,FSUBR,,LISTAT:
00450
00460 MKAT <PROGN,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
00470 ;?????? IS SETQ RIGHT HERE?
00480 IFN ALVINE,<MKAT<GRINDEF>,FSUBR
00490 MKAT<ED,BAKGAG>,SUBR>
00500 MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
00510 MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
00520 MKAT1 QUOTE,FSUBR,FUNCTION
00530 MKAT1 %CLRBFI,SUBR,CLRBFI
00540 MKAT1 .ERROR,SUBR,ERROR
00550 MKAT1 LINRD,LSUBR,LINEREAD
00560 MKAT1 UNBOND,SUBR,UNBOUND
00570 MKAT1 ECHO,SUBR,TTYECHO
00580 MKAT1 FUNCT,FSUBR,*FUNCTION
00590 MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
00600
00610 ;## LABELS ON READ AND LISP EVAL FOR BOOTS
00620 MKAT READ,SUBR,,READAT:
00630 MKAT EVAL,LSUBR,O,EVALAT:
00640 MKAT PREVIOUS,VALUE,,PREVAT:
00650 PREVIOUS: NIL ;WMT-LAST VALUE AT TOP LEVEL OF LISP
00660 MKAT FPROTECTION,VALUE
00670 FPROTE: INUM0 ;WMT-FILE PROTECTION ON ALL OUTPUT FILES
00680
00690 MKAT ASCII,SUBR,A
00700 MKAT QUOTE,FSUBR,,CQUOTE:
00710 MKAT INUM0,SYM
00720
00730 PUTOB T,.+1
00740 TRUTH: XWD -1,.+1
00750 XWD VALUE,.+1
00760 XWD VTRUTH,.+1
00770 XWD PNAME,.+1
00780 XWD [PSTRCT(T)],0
00790 VTRUTH: TRUTH
00800
00810 PUTOB NIL,0
00820 FAKNIL: XWD -1,.+1 ;*** FAKE NIL ATOM HEADER FOR ACCESSING PRP LST
00830 CNIL2: XWD VALUE,.+1
00840 XWD VNIL,.+1
00850 XWD PNAME,.+1
00860 XWD [PSTRCT(NIL)],0
00870 VNIL: NIL
00880
00890 MKSY1 %LCALL,*LCALL
00900 MKSY1 %AMAKE,*AMAKE
00910 MKSY1 %UDT,*UDT
00920 MKSY1 .MAPC,*MAPC
00930 MKSY1 .MAP,*MAP
00940 MKAT1 %NOPOINT,VALUE,*NOPOINT
00950 %NOPOINT: NIL
00960
00970 MKAT1 %TTYUC,VALUE,*TTYUC
00980 %TTYUC: NIL
00990
01000 UNBOUND: XWD -1,.+1
01010 XWD PNAME,.+1
01020 XWD [PSTRCT(UNBOUND)],0
01030 PAGE
00010 MKAT1 EXPN1,SUBR,*EXPAND1
00020 MKAT1 EXPAND,SUBR,*EXPAND
00030 MKAT1 PLUS,SUBR,*PLUS,.
00040 MKAT1 DIF,SUBR,*DIF,.
00050 MKAT1 QUO,SUBR,*QUO,.
00060 MKAT1 TIMES,SUBR,*TIMES,.
00070 MKAT1 APPEND,SUBR,*APPEND,.
00080 MKAT1 RSET,SUBR,*RSET,.
00090 MKAT1 GREAT,SUBR,*GREAT,.
00100 MKAT1 LESS,SUBR,*LESS,.
00110 MKAT1 PUTSYM,SUBR,*PUTSYM
00120 MKAT1 GETSYM,SUBR,*GETSYM
00130 MKAT1 RPTSYM,SUBR,*RPUTSYM
00140 MKAT1 RGTSYM,SUBR,*RGETSYM
00150
00160 ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
00170
00180 PUTOB NUMVAL,.+1
00190 XWD -1,.+1
00200 XWD SUBR,.+1
00210 XWD NUMVAL,.+1
00220 XWD SYM,.+3
00230 XWD FIXNUM,[NUMVAL]
00240 XWD -1,.-1
00250 XWD .-1,.+1
00260 XWD PNAME,.+1
00270 XWD [PSTRCT(NUMVAL)],0
00280
00290 MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
00300
00310
00320 ;## QUEUE ATOMS AND OTHER NEW FNS.
00330
00340 MKAT<GTBLK,ERRCH,RDNAM>,SUBR
00350 MKAT<INUMP,NUMTYPE>,SUBR
00360 MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
00370 MKAT<RENAME,DELETE,INITFL>,FSUBR
00380 IFN QALLOW< ;%% [1]
00390 ML<DISP,CPU,FORMS,LIMIT,COPIES>;;##
00400 MKAT<QUEUE>,FSUBR; ;##
00410 > ;%% [1]
00420 MKAT1 ISFILE,SUBR,LOOKUP
00430
00440 IFN QALLOW< ;%% [1]
00450 ;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
00460 IFN QSWEXT<
00470 ML<DEAD,AFTER>
00480 ML<MODIFY,KILL,JOB,DEPND,UNIQUE>
00490 ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
00500 > ;##END OF EXTENDED SWITCHES
00510 > ;%% END OF QALLOW CONDITIONAL [1]
00520
00530 ;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
00540
00550 ML ERRORX
00560 MKAT1 INTPRP,SUBR,INITPROMPT
00570 ;WMT- STRT CHANGED TO LSPRET
00580 MKAT1 LSPRET,FSUBR,**TOP**
00590 MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
00600 MKAT<MEMB,NEXTEV>,SUBR
00610 MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
00620 MKAT<EVALV,OUTVAL>,SUBR
00630
00640 IFN REALLC <
00650 ;%% NEW DYNAMIC REALLOCATION FUNCTION
00660 MKAT1 REALLO,SUBR,REALLOC
00670 >
00680 ; [UT] ADDITIONS
00690 MKAT <GCWORDS,RPDLIM,SPDLIM,FSLIM,FWLIM,FWCNT,FSCNT>,SUBR
00700 IFE SFDFLG,< ;WMT
00710 MKAT PATH,FSUBR
00720 MKAT SCAN,SUBR
00730 >
00740
00750 ;$$ MORE EXTENSIONS INCLUDING READ MACROS
00760 ML READMACRO
00770 MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
00780 MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR
00790 MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
00800 MKAT1 FALSE,FSUBR,SPECIAL
00810 MKAT1 FALSE,FSUBR,NOCALL
00820 MKAT1 FALSE,FSUBR,DECLARE
00830 MKAT1 FALSE,FSUBR,NILL
00840 MKAT1 APPLY.,SUBR,APPLY#
00850 MKAT1 .MAX,SUBR,*MAX
00860 MKAT1 .MIN,SUBR,*MIN
00870
00880 ;*** NEW RUTGERS FUNCTIONS
00890 MKAT1 DOEXIT,SUBR,EXIT
00900 MKAT1 TTYCLR,SUBR,TALK
00910 MKAT1 GETICH,SUBR,INCH
00920 MKAT1 GETOCH,SUBR,OUTCH
00930 MKAT <DTIME,EQSTR,EDITCH>,SUBR
00940 MKAT1 DODATE,SUBR,DATE
00950 MKSY1 ERRST1,*ERRSET1
00960 MKSY1 ERRST2,*ERRSET2
00970 MKAT1 .NCONC,SUBR,*NCONC
00980 MKAT1 AP2,SUBR,*APPLY
00990 MKAT <DEFLIST,DEFP,DEFV>,FSUBR
01000 MKAT1 RERDCH,SUBR,REREADCH
01010 MKAT1 PROGN,FSUBR,NOCOMPILE
01020 ML EDITEXPR
01030 MKAT1 INTSTR,VALUE,INTERNSTR
01040 INTSTR: NIL
01050
01060 ;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
01070 MKAT1 BIOCHN,VALUE,#%IOCHANS%#
01080 MKAT1 BPMPT,VALUE,#%PROMPTS%#
01090 MKAT1 BINDNT,VALUE,#%INDENT
01100 BIOCHN: NIL
01110 BPMPT: NIL
01120 BINDNT: INUM0
01130
01140 VOBLIST: OBLIST
01150 VBASE: 8+INUM0
01160 VIBASE: 8+INUM0
01170
01180 ;WMT - ADD INUM AS AN ATOM (VALUE OF NUMTYP)
01190 ML <PNAME,INUM,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
01200 $EOF$,LABEL,FUNARG,LSUBR,MACRO>
01210
01220 PUTOB ?,.+1
01230 QST: XWD -1,.+1
01240 XWD PNAME,.+1
01250 XWD [PSTRCT(?)],0
01260
01270 VBPORG: INUM0
01280 VBPEND: INUM0
01290
01300 ;MKAT ACHLOC,SYM
01310 ;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
01320 ;%% THIS WAS A PREDECESSOR TO THE FUNCTIONS UNDER SWITCH "REALLC"
01330 ;%% NO LONGER USEFUL
01340
01350 PAGE
00010 ;
00020 ;*** ALL THE ATOMS IN COMPILED LISP ROUTINES
00030 ;*** (GETS PNAMES INTO HI SEG)
00040
00050 IFN PNAMES < ;*** OFF TO BUILD A STRIPPED SYSTEM.
00060
00070 MK<XTR, ?," *COMMENT*",DPRINT,BRKWHEN,EDITXTR,F:>
00080 MK<" has no properties on PRETTYPROPS.",ENTER,BKPOS,CURRCOL,PPCOM>
00090 MK<EXPBPS,SUBLIS,MOVEI,HLRZ@,UNFIND,UNBLOCK,GRINPROPS,MISER,NOTANY>
00100 MK<JUMPE,STKNAME,INSERT,MAXLOOP EXCEEDED,MAXLOOP,LPTLENGTH,F=,TIMER>
00110 MK<Functions-Loaded,DSUBST,TIMES,UPFINDFLG>
00120 MK<FSUBR -- TAKES ONLY ONE ARGUMENT,PREVEV,NOTHING SAVED,UNDOLST>
00130 MK<INTERSECTION,SUBSET,INTERNL,COMSQ,RETFROM,Nothing-Saved,MOVEM>
00140 MK<LASTPOS,USERERRORX,EXTRACT,STKCOUNT,UNDONE,AROUND,PRINLEV,RGETSYM>
00150 MK<HRRZ@,BF,REMPROPS,EXPFS, ...],DSKOUT,LESSP>
00160 MK<" unbreakable unless IN something.",DE,P:,DF,REMOVE,MOVNI,BI,LSUBST>
00170 MK<UNION,JUMPN,UNTRACEV,PUSHJ,UNTRACE,LASTVALUE,EXPFWS,LEXPR,N?>
00180 MK<SHOULD BE LIST OF ATOMIC ARGUMENTS,SHOULD BE LIST,BK,LASTWORD,EVERY>
00190 MK<BRKTYPE,USERMACROS,SPRINT,NOTEVERY,GETSYM,LC,PRINTLEV,IF,PRINTMACRO>
00200 MK<PRINTC,HLLZS@,UNSAVE,START,V:,PUTLIST,BO,PRETTYPROPS,PRETTYFLG,DM>
00210 MK<STRING TOO SHORT - SUBSTRING,CAIE,SUBST,DO,SUBSTRING,QUOTIENT>
00220 MK<THROUGH,"not editable.",LI," not in Symbol Table.",broken,STKNTH,FP>
00230 MK<THROW,IN,CAME,PPL*,FUNTYPE,STKSRCH,FS,OK,BY,RI,LO,HRRZS@,CAIN>
00240 MK<LP,CALL,EX,SURROUND,DSK:,BIND,"[",CAMN,%%V,PP,RPUTSYM,RO,"]",",MV>
00250 MK<TO,TTYMSG,&,UP,HERE,NX,DIRF,PUTSYM,<)>,EXCH,BKEV,*,%%GCTIME>
00260 MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC,BKFV,SW,... >
00270 MK<- LOCATION UNCERTAIN,<\P>,MARK,ARGS,:::,File-Dumped,SAVE>
00280 MK<$%DOTFLG," . ",SOJE,%%SPEAK,COMS,TDZA,INIT,FROM,%%TIME,SOME,UNDO>
00290 MK<"*WARNING - NOCALL Function ",MOVE,PLEV,LXPD,:,POPJ,HRRM>
00300 MK<"NON-NUMERIC COUNT - RPTQ",SOJN,↑↑,COPY,TTY:,=,WITH,*ANY*,>
00310 MK<"BINARY PROGRAM SPACE EXCEEDED",←←,". . . ",%DEFINE>
00320 MK<" is not a breakable function.",@," is being unbroken.",None-Found,A>
00330 MK<PUSH,B,TEST,%CATCH,HLRZ,C,"No Backup: ",%READIN,TYPE,D,E,JRST,THRU>
00340 MK<PLUS,##,F,RPTN," to ",%ERDEPTH,%DEREAD,!NX,STOP,HRRZ,I,RPTQ,ADD>
00350 MK</BREAK1,PP*,L,M,N,P,!0,R,*RENAME,S,not,BKE,BKF,MBD,#1>
00360 MK<**,NOT A TAIL - LDIFF,#2,NOT BLOCKED,EDIT-SAVE,#3,%DEVP,X>
00370 MK<Y,!UNDO,BFP,--,NO EVAL BLIP - RETFROM,Z,!VALUE,EDIT4E,<\>,%LOOKDPTH>
00380 MK<LCL,PP-LABELS,<\#\>,LAP,↑,←,EMBED," Redefined.",DIFFERENCE,%PRINFN, >
00390 MK<DIFFERENT EXPRESSION,FILBAK,DIR,! ,PP-COMMENT,EDIT:,LABELS,CHANGE>
00400 MK<%PREVFN%,BKV,CALLF@," ",PP-FORMAT,DRM,CALLF,MIN,%TRSET,%TRSETQ>
00410 MK<=EDITV,BRACKETS,PP-MISER,CATCH,DSM,MAKEFN,PP-VALUE,MAX,BREAK1>
00420 MK<BREAKIN,BREAK0,BREAKMACROS,BREAK,LDIFF,JCALL,FOR,ORF,MSG,*NOPOINTDSK>
00430 MK<JCALLF@,JCALLF,CLEARM,MEMBFN,Redefined,CLEARB,*RSETERX,PEEKC,SUB>
00440 MK<NTH,EDITCOMSL,GETDEF,ALIAS,NEX,EDITDSUBST,<"(">,*PG*,EDITE,REPACK>
00450 MK<BLOCKED,BLOCK,ADDPROP,DELIM,PPL,<")">,JSP,FNDBRKPT,SELECTQ,USE>
00460 MK<EDITFPAT,LPQ,EDITFINDP,EDITF,EDITFNS,PP-RMACS,PP-LSEG,SPACES, . >
00470 MK<BKFNLIST,ALLFNS,POP,"Set ",BEFORE,LSP,HGHIN,TRACEVFNS,TRACEVed>
00480 MK<TRACEV,TRACEDFNS,TRACE,LCONC,-IN-,BRKAPPLY,BRKCOMS,COMMENTFLG>
00490 MK<COMMENT,NCONC1,OPS,AFTER,ORR,EDITL,::,EDITL0,UNDEF,GREATERP>
00500 MK<BROKENFNS,BROKEN-IN,HRLM@,ERXACTION,BRKFN,FROM?=,EDITMV,EDITMBD>
00510 MK<EDITMACROS,MAPATOMS,QSP,DSKLENGTH,NAMESCHANGED,Broken,REPLACE>
00520 MK<GRINDEF,FILES-LOADED,LAPKLST,EDITOPS,LASTAIL,EDITOF,EDITP,DREVERSE>
00530 MK<MAXLEVEL EXCEEDED,MAXLEVEL,DREMOVE,EDITQF,MARKLST,DUMPATOMS>
00540 MK<TCONC,SECOND,==,EDITRACEFN,PUT,BKSET,BKSETQ,HRRM@,BELOW,DSKIN>
00550 MK<REMLIST,ASSOC#,?=,PRINAC,PRINA,TAILP,LAPQLST, = ,THIRD,SUBPAIR>
00560 MK<UNBREAK0,UNBREAKABLEFNS,ARGUMENT LIST?,ARGPRINT,BRKEXP>
00570 MK<ARGUMENTS NOT FOUND,OCCURRENCES,??,UNBREAK,EDITV,GRINL,***,LAPSLST>
00580 MK<LAPLST,E:,FORMS:,MBD:,PRINL,PRINLC,NOPRETTYPROPS,EDIT,LINES>
00590 MK<" Not Yet Defined.">
00600 MK<%%DTIME," conses",<" msec clock, ">,<" msec GC), ">,<" msec CPU (">>
00610 MK<" can't be broken into."," not found in ">
00620 MK<%EDITPLEV,%BKPRINLEV,BREAK0B> ;WMT
00630 >
00640
00650 BFWS:
00660 EFWS: 0
00670 RELOC
00680 XLIST ;*** LITERALS (INCLUDING HI-SEG FWS) ARE HERE
00690 LIT
00700 LIST
00710 BHORG: 0
00720 RELOC
00730 PAGE
00010 SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY)
00020
00030
00040 FIRST: CLEARM 0,SBPS ;SET UP INITIAL ALLOCATIONS FOR SPACE
00050 HRRZI A,BFWS-FS ;THIS IS THE SIZE OF THE ORIGINAL FS
00060 HRRZM A,SFS
00070 HRRZI A,EFWS-BFWS ;THIS ALLOWS ONLY THE INITIAL
00080 HRRZM A,SFWS ;FWS
00090 HRRZI A,0 ;THE INITIAL ALLOCATION FOR SPDL
00100 HRRZM A,SSPDL
00110 HRRZM A,SRPDL ;AND FOR RPDL IS SET UP IN INALLC
00120 HRRZI A,FS
00130 HRRZM A,FSO ;THIS SETS UP INITIAL FS POINTER
00140 HRRZI A,BFWS ;THIS SETS UP INITIAL FWS ORIGIN POINTER
00150 HRRZM A,FWSO#
00160
00170 HRRZI A,EFWS
00180 HRRZM A,EFWSO#
00190
00200
00210 MOVEI A,FS
00220 ADDM A,VBPORG ;SET UP VARIABLE FOR BPS ORIGIN
00230 SOS A
00240 ADDM A,VBPEND
00250
00260 MOVE A,.JBREL
00270 HRLM A,.JBSA
00280 RESET
00290 MOVEI A,START
00300 HRRM A,.JBSA ;SET STARTING ADDR
00310 HRRZS .JBHRL ;*** SET TO SAVE ENTIRE HI-SEG
00320
00330 SETOM INITFW# ;FLAG FOR STANDARD INITIALIZATION OF
00340 SETZM JRELO# ;SIZES, AND TO INDICATE CORE WAS EXPANDED
00350
00360 JRST INALLC
00370 PAGE
00010 SUBTTL INTERNAL SYMBOLS FOR MACRO REFERENCES
00020
00030
00040 DEFINE MKENT (A)<
00050 INTERNAL A>
00060 ;##DEBUG QUEUE
00070 MKENT <CADAR,ATMOV,CADAR,CORUSE,DEV>
00080 IFN QALLOW< ;%% [1]
00090 MKENT <COPIES> ;%% [1]
00100 > ;%% [1]
00110 MKENT <EXT,HGHDAT,INUM0,INUMIN,IOPPN,LISTAT,MORCOR,MOVDWN>
00120 MKENT <NXTIO,OLDCU,SIXMAK,STNIL>
00130
00140 IFN BIGNMS<
00150 MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,FIX2,NUM1,NUM3,BPR>>
00160 MKENT <OPR,FLOOV,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
00170 MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL>
00180 MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
00190 MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
00200 MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
00210 MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
00220 MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
00230 ;WMT- STRT CHANGED TO LSPRET
00240 MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET>
00250 MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
00260 IFN ALVINE,<MKENT<PSAV1,BKTRC>>
00270
00280 ;%% RECENT ADDITIONS
00290 MKENT <FLTYIA,SIXATM,BNINIT,RDFILE,UFDINP,MYPPN>
00300 IFN QALLOW< ;%% [1]
00310 MKENT <QUEUE> ;%% [1]
00320 > ;%% [1]
00330 MKENT <SYSIN0,SYSIN1,SYSINI,SYSINP>
00340 IFN REALLC <
00350 MKENT <FWCNT,FSCNT,REALLO>
00360 >
00370
00380 ;$$ FOR ALAN'S DIRECT ACCESS INPUT
00390 MKENT <ININBF,TYI2,TYIA,INCH>
00400
00410 ;## FOR BILL'S DIRECT ACCESS INPUT/OUTPUT
00420 MKENT <AIN.2,AIN.4,AIN.7,AOUT.2,CHANNE>
00430 MKENT <CHNSUB,CHTAB,DEVDAT,ENTR,IOSUB>
00440 MKENT <LOOKIN,OUTCH,OUTERR,POPAJ,PPN,SMAC>
00450 MKENT <TABSR1,TABSRC,TYI2E,TYI2Z,TYI3B,TYO2X>
00460 MKENT <TYO5,AIOP,SETIN>
00470
00480 ;$$ FOR ALVINE
00490 MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
00500
00510 ;%% FOR THE MODIFIED ARITHMETIC PACKAGE
00520 MKENT <FIXNUM,FLONUM>
00530
00540 ;WMT
00550 MKENT <CCTLR,CCTLH,CCTLE,CCTLB,CCTLD,CCTLG,CCTLX>
00560 MKENT <SFS,SFWS,SRPDL,SSPDL,SBPS>
00570
00580 PAGE
00590 END FIRST
00600
00610 β